program pisco
  !	dust + gas radiative transfer in a circumstellar disk
  !	with nested r-theta grids tranformed onto rectangular grids
  !	for the rad xfer
  !	expand the innner grid by 8 to resolve the inner rim better
  !	start with Chiang & Goldreich disk model
  !	with hydro equil for vertical structure
  !	then do full dust rad xfer
  !	start line calculation with random walk (diffusion) solution
  !	for first J; previous J for subsequent Js
  !	il=1: v=0,J=Ju+1  il=2: v=0,J=Ju  il=3: v=0,J=Ju-1
  !	il=4: v=1,J=Ju    il=5: v=1,LTE   il=6: v=2,J=Ju
  !	il=7: v=1e,J=Ju   il=8: v=1,thin
!!$
!!$ STH: Samuel Harrold

!!$ USE MODULEar programming for easier writing, testing, reading, modification, and reuse of components. MODULEs in F90 replace COMMON and BLOCK DATA from F77.
!!$ TODO: replace individual cooling modules wiht ModCoolGasTot
  USE ModArray
  USE ModParms
  USE ModFuncs

  implicit real*8 (a-h,o-z)
#include "mpif.h"

!!$ STH: Use explicit INTERFACEs for external subprograms that are not CONTAINed within MODULEs to ensure that the compiler can perform the necessary consistency checks.
  INTERFACE
  END INTERFACE

  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  parameter (mc = 256)
  parameter (mrz = 512)
  parameter (mmap = 1024)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /heat/ gmmdot,acom,pxr,axr,bxr,epspe,agas,sigma, &
       colin,colup,xco,xwat
  common /angls/ dcost,dcos9,rot,irot
  common /parmz/ rgrid1,r0,r1,sigma0,sigma1,ocol,pcol,qcol, &
       avisc,xmstar,xlstar,tuv,xuv,tsubl,gsubl,tburn,xburn, &
       coswind,xc,xsi,ac,asi,xmdot,wmdot,vwind, &
       xco0,xwat0,tfrco,tfrwat,xmol,tfrmol,tdiss,coldiss, &
       kit,lit,mit,nnt,lx,lrot,reuse
  common /xj/ xju,xjp,xjq,xjr,xk
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /vels/ wr(mt,mr,mg),wth(mt,mr,mg),wph(mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /cube/ cube(mc,mc,mc),ngc
  common /exptab/ expi(10239),too
  dimension mpistatus(MPI_STATUS_SIZE)
  dimension taud(mu,mt),dtac4(mt)
  dimension colr(mt,mr,mg),colz(mt,mr,mg),tauv(mt,mr,mg)
  dimension tgz(mrz,mrz,mg),dgz(mrz,mrz,mg),ddz(mrz,mrz,mg)
  dimension ddl(4,mt,mr,mg),rufl(mt,mr,mg)
  dimension dt(mt,mr,mg),dm(mt,mr,mg)
  dimension fw(mw,ml,2*mt),fwj(mw,ml),fwq(mw*ml,2*mt)
  dimension spec(mw,mu)
  dimension frame(mc,mc),picture(mt,mr,mg)
  dimension con(mmap)
  logical ifmpi,doplot,doprint,wait
  logical bipolar,smooth,lte,reuse
  logical ifrim,lastit,inwind
  logical badnum,good
  character*16 monfile,pfile,qfile,rfile,hfile,ifile,lockline
  character*16 chemfile

!!$ DECLARE ADDITIONAL VARIABLES

!!$ TODO: write out dg instead of defining nGasArray = dens. nGasArray is commented out for now
!!$ !!$ nGasArray = array of gas particle density throughout the disk for plotting without using dm because dm is frequently overwritten. dm = dens*(r/r0)**2
!!$ PopRatioArray  = array of ratios of upper-to-lower population levels for a chosen transition throughout the disk for plotting without redefining dd because dd is frequently overwritten
!!$ NtostarArray = array of column density to the star throughout the disk defined as colg from Lacy as the harmonic average of the vertical and horizontal column densityies
!!$ TODO: Why is colg defined as the harmonic average?
!!$ TODO: Make cooling arrays inside main program using modular cooling functions
!!$ For now cooling arrays are in outdated common blocks. Do same for heating.
  REAL, DIMENSION(mt, mr, mg) :: &
       PopRatioArray, NtostarArray ! nGasArray
!!$ CoolGas(H2O/CO/H2)(Rot/Vib)Array = cooling due to H2O/CO/H2
!!$ rotation/vibration for plotting as cooling maps
!!$ CoolGas(CII/OI)Array = cooling due to CII/OI fine structure transition
!!$ CoolGasTotArray      = total cooling due to all processes for plotting in cooling map
  COMMON /CoolGasArr/ &
       CoolGasH2ORotArray(mt, mr, mg), CoolGasH2OVibArray(mt, mr, mg), &
       CoolGasCORotArray(mt, mr, mg),  CoolGasCOVibArray(mt, mr, mg), &
       CoolGasH2RotArray(mt, mr, mg),  CoolGasH2VibArray(mt, mr, mg), &
       CoolGasCIIArray(mt, mr, mg), CoolGasOIArray(mt, mr, mg), &
       CoolGasTotArray(mt, mr, mg)
!!$ Abund(CII/OI/e/H/H2)Array = abundances of CII/OI/e/H/H2 relative to all gas particles
  COMMON /AbundArr/ &
       AbundCIIArray(mt, mr, mg), AbundOIArray(mt, mr, mg), &
       AbundeArray(mt, mr, mg), &
       AbundHArray(mt, mr, mg), AbundH2Array(mt, mr, mg)
!!$ TODO: modularize dust/gas heating/cooling and gastemp
!!$ Declare variables for components of heating
!!$ HeatGas(PE/XR/Accr)Array  = heating of gas due to photoelectric effect/xrays/
!!$ viscous accretion for plotting as heating maps
!!$ Heat(Gas/Dust)TotArray = total heating of gas/dust 
!!$ CoolDustTotArray       = total cooling of dust due to radiation
!!$ (Heat/Cool)TotArray    = total heating/cooling including all gas and dust
!!$ AccomArray = heat exchange due to accomodation coefficient between gas and dust
  COMMON /GasTempArr/ &
       HeatGasPEArray(mt, mr, mg), HeatGasXRArray(mt, mr, mg), &
       HeatGasAccrArray(mt, mr, mg), HeatGasTotArray(mt, mr, mg), &
       HeatDustTotArray(mt, mr, mg), HeatTotArray(mt, mr, mg), &
       CoolDustTotArray(mt, mr, mg), CoolTotArray(mt, mr, mg), &
       AccomArray(mt, mr, mg)

!!$ TODO: move physical constants to a module
  !	physical constants

  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0+00)
  parameter (ten = 1.0d+01)
  parameter (hun = 1.0d+02)
  parameter (thrq = 0.75d+00)
  parameter (half = 0.5d+00)
  parameter (quart = 0.25d+00)
  parameter (fifth = 0.2d+00)
  parameter (tenth = 0.1d+00)
  parameter (small = 1.0d-06)
  parameter (tiny = 1.0d-16)
  parameter (zilch = 1.0d-200)
  parameter (pi = 3.14159265d+00)
  parameter (clt = 2.9979d+10)
  parameter (hpl = 6.6262d-27)
  parameter (hc2 = 5.955d-06)
  parameter (bk = 1.3807d-16)
  parameter (sigsb = 5.670d-05)
  parameter (au = 1.496d+13)
  parameter (rsun = 6.96d+10)
  parameter (xlsun = 3.90d+33)
  parameter (xmsun = 1.99d+33)
  parameter (secyr = 3.156d+07)
  !	mass / gas particle
  parameter (xmg = 4.0d-24)
  parameter (vkms = 1.0d+05)

  sqrt2 = sqrt(two)
  alog2 = log(two)
  sqrtpi = sqrt(pi)
  tpi = two*pi
  fpi = four*pi
  third = one/3.0d+00
  hc = hpl*clt
  hck = hc/bk

  ifmpi = .true.
  if(ifmpi) then
     call mpi_init(ierr)
     call mpi_comm_size(MPI_COMM_WORLD,mysize,ierr)
     call mpi_comm_rank(MPI_COMM_WORLD,myrank,ierr)
     ifmpi = (mysize.gt.1)
  else
     mysize = 1
     myrank = 0
  endif

  doprint = (myrank.eq.0)
  doplot = (myrank.eq.mysize/2)
  if(doprint) then
     print '("Running pisco with",i4," processors")', mysize
  endif
  wait = .true.
  !	reuse old dust disk model and Doty abundances?
  reuse = .false.

  !	initialize expi arrays
  x = expinit()

  !	initialize plot files

!!$ STH: Write out branch profile as 'specs'
!!$        if(doprint) then
!!$           print '(" Enter name of output file: ",$)'
!!$           read '(a16)', monfile
!!$           if(index(monfile,' ').lt.2) monfile = 'specs'
!!$        endif
  monfile = 'specs'

  if(ifmpi) call mpi_bcast(monfile,16,MPI_CHARACTER, &
       0,MPI_COMM_WORLD,ierr)
  if(doplot) then
     open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
          access='sequential')
     write(8,'("empty")')
     close(unit=8)
     last = index(monfile,' ')-1
     last = min(last,14)
     pfile = monfile(1:last)//'.p'
     open(unit=11,file=pfile,access='sequential')
     qfile = monfile(1:last)//'.q'
     open(unit=12,file=qfile,access='sequential')
     rfile = monfile(1:last)//'.r'
     open(unit=13,file=rfile,access='sequential')
     !          hfile = monfile(1:last)//'.h'
     !          open(unit=14,file=hfile,access='sequential')
     !          ifile = monfile(1:last)//'.i'
     !          open(unit=15,file=ifile,access='sequential')
     !	note: doplot processor writes log
     ifile = monfile(1:last)//'.log'
     open(unit=16,file=ifile,access='sequential')
     monfile = ''
  endif

  !	molecular constants

  !	band strength: cm-1/cm-2, collision rate coefficient = sigma*v: cm^3/s
  !	C2H2 v4+v5
  moltype = 4
  we = 1340.
  be = 1.1766
  ce = zero
  ae = 0.0
  sv = 3.12d-18
  xmol = 1.0d-06
  !	a wild guess
  gcoll = 1.0d-13
  tcoll = 4.0d+04
  popiso = 3.2d-02
  nl = 2
  !	NH3 v2 (average of s+a)
  moltype = 3
  we = 950.
  be = 9.947
  ce = 6.227
  ae = 0.0
  !	for each of s, a
  sv = 1.06d-17
  xmol = 4.0d-06
  !	a wild guess
  gcoll = 1.0d-13
  tcoll = 1.d+04
  popiso = 3.0d-03
  nl = 3
  !	CO
  moltype = 1
  we = 2143.25
  be = 1.9225
  ce = zero
  ae = 0.01748
  sv = 1.04d-17
  xmol = 1.0d-04
  !	gcoll = 4.5d-14*T*exp(-68/T^1/3) (Gonzalez-Alfonso etal 2002)
  gcoll = 4.5d-14
  tcoll = 7.0d+01**3
  popiso = 1.6d-02
  nl = 2
  !	C2H2 v5
  moltype = 5
  we = 729.16
  be = 1.1766
  ce = zero
  ae = -4.4d-03
  !	Q or P+R band strength
  sv = 1.46d-17
  xmol = 1.0d-06
  !	a wild guess
  gcoll = 1.0d-13
  tcoll = 4.0d+03
  popiso = 3.2d-02
  nl = 3
  !	SiO
  moltype = 1
  we = 1241.5
  be = 0.7267
  ce = zero
  ae = 0.00494
  sv = 4.566d-18
  xmol = 1.0d-05
  !	gcoll = 5d-12*(T/2000)^2.6 (Bieniek & Greene 1983)
  gcoll = 8.2d-14
  tcoll = 4.16d+04
  popiso = 5.0d-02
  nl = 2
  !	HCN v2
  moltype = 2
  we = 711.98
  be = 1.4872
  ce = zero
  ae = -8.0d-03
  sv = 5.15d-18
  xmol = 1.0d-06
  !	a wild guess
!!$ STH: change gcoll (collision cross secton) to test LTE approx
  gcoll = 1.0d-13 ! original gcoll (NLTE)
!!$ gcoll = 1.0d-00 ! LTE gcoll
  tcoll = 4.0d+03
  popiso = 1.6d-02
  nl = 3

  !	if reading in a chemfile, xmol multiplies the abundance
  !	I can''t set nl = 2 since I would skip the R branch line
  nl = 3

  !	skip molecular lines if moltype = 0
  !	moltype = 0

  wec = we/clt
  acoeff = 8.*pi*clt*we**2*sv
  !	this would include decay to v4 but not excitation from v4
  !	if(moltype.eq.4) acoeff = acoeff+8.*pi*clt*we**2*(1.46d-17)
  wkms = we*vkms/clt
  hcb = hc*be
  hcc = hc*ce
  hcwe = hc*we

  !	default input parameters

  !	outer radius of grid 1
  rgrid1 = 0.20*au
  !	column density knee radius
  r0 = au
  !	outer knee radius
  r1 = 400.*au
  !	gas column density in disk at r0 (g/cm2 to be converted to mol/cm2)
  sigma0 = 100.0
  !	column density of inner disk at r0
  sigma1 = 0.0
  !	radial power law negative index
  !	C&G use 1.5, but D''A finds ~1.0 for constant alpha
  !	this is now for pres, so ~ density pcol + 1.5
  pcol = 2.5
  !	radial power law positive index for column density inside r0
  qcol = 0.0
  !	negative index for extra inner disk
  ocol = 2.5
  !	to specify sigma at 1 AU instead of inside r0
  !        sigma0 = sigma0*((au/r0)**pcol+(r0/au)**qcol)
  !	turbulent viscosity parameter / dust density for dust settling
  !	make negative to make temperature dependent
  avisc = 1.0d-02
  rhod = 3.0d+00
  !	radius of star
  rstar = 2.0*rsun
  !	mass of star (M_sun)
  xmstar = 1.0
  !	luminosity of star (L_sun)
  xlstar = 4.0
  !	add a hot source of UV to stellar spectrum
  tuv = 1.5d+04
  xuv = 0.1
  !	carbon and silicon fraction in grains
  xc = 0.1
  xsi = one
  !	carbon and silicate rolloff radius (cm) (amax = 0.1 cm)
  ac = 1.0d-05
  asi = 1.0d-05
  !	dust sublimation temperature coefficients (for both carbon and silcate)
  !	tsubli = tsubl*pres**gsubl
  tsubl = 600.
  gsubl = 0.02
  !	destroy carbon grains if tgas > tburn
  tburn = 0.
  !	enhance CO where carbon is burned
  xburn = 1.
  !	enhancement of stellar radiation by reflection and emission from disk
  !	no longer used
  enhanc = 0.5
  !	accretion rate for heating
  xmdot = 1.0d-08
  !	dust to gas heat flow acommodation coefficient
  acom = 0.05d+00
  !	x-ray luminosity of star
  pxr = 0.0d-04
  !	x-ray absorption cross section per H
  !	~1e-22 at 1 keV, falling as ~E^-2.5 (Gorti&Hollenbach)
  axr = 1.0d-22
  !	extra x-ray parameter not currently used
  bxr = 2.5
  !	photoelectric heating of gas
  npe = nu-4
  epspe = 0.05d+00
  !	abundances for cooling function; should vary in disk
  xco0 = 1.0d-04
  xwat0 = 1.0d-04
  tfrco = 3.0d+01
  tfrwat = 1.5d+02
  !	angular width of wind-swept cone
  coswind = 0.5
  !	mass-loss rate in wind
  wmdot = 0.0d-10
  !	wind speed
  vwind = 10.0
  !	molecule destruction temperature
  !	CO should extend in to where T = 4000.
  tdiss = 4000.
  !	molecule freeze-out temperature (negative to be midplane temperature)
  tfrmol = 50.
  !	destroy molecules where exposed to stellar UV or x-rays
  !	this is now the radial column, not the vertical
  !	GNI04 say 1e21 (vertical) for CO, and larger for bigger molecules
  coldiss = 1.0d+22
  !	assume H is atomic, so increase collision rate, out to colHI
  !	GNI04 say 4e21 (vertical), but PDRs have colCO ~ colHI
  colhi = 0.0d+22
  !	fluorescent excitation band strength
  !	multiply by gguv = gg(iufl)
  sfluor = zero
  wfl = 5.0d+04
  fluor = fpi*sfluor/(hc*wfl)
  !	microturbulent velocity parameters
  dvturb0 = 0.25*vkms
  dvturb1 = 0.25*vkms
  !	velocity step
  dv = 0.05*vkms

  !	assume LTE level populations for first iteration?
!!$ STH: Assume LTE level populations for first iteration
!!$ when testing LTE assumptions.
  lte = .FALSE.
  !	C&G iterations
  kit = 4
  !	dust radiative transfer iterations
  lit = 16
  !	maximum line radiative transfer iterations (0 for LTE)
  mit = 16
  !	number of grain sizes or types; first half are carbon
  !	parameter (ma = 32)
  na = 24
  nac = 12
  !	number of line types including continuum
  nl1 = nl+1
  !	number of wavelengths for dust spectrum
  !	parameter (mu = 64)
  nu = 64
  !	number of wavelengths for line spectra
  !	parameter (mw = 1024)
  nw = mw
  nw2 = nw/2
  wmid = (nw+one)/two
  !	number of nested grids (<= 12)
  !	parameter (mg = 20)
  ng = 12
  !	grid density multiplier for inner grid
  !	nn9 = 8 make pretty pictures, but it takes forever for the lines
  nn9 = 4
  !	parameter (mr = 128)
  nr = 128
  !	costh runs from 1 to 0
  !	set nnt = nr so r*dcosth = dr at outer edge of grids
  !	or maybe it''s better to have finer angular steps
  !	and if mult of 3 can use 12 processors
  nnt = 3*nr/2
  !	parameter (mt = 192)
  !	don''t bother calculating at theta above disk
  nt = nnt/2
  !	need to calculate all nnt if wmdot /= 0
  if(wmdot.gt.zero) nt = nnt
  !	nx = 16 seems to be OK for SED, but maybe not for disk structure
  nx = 64
  !	use lx,lrot for nx,nz,nrot for the line calculation
  lx = 16
  !	make nrot a fraction of nnt (or vice versa?) and a multiple of mysize
  nrot = nnt/2
  if(mod(nrot,mysize).ne.0) then
     if(doprint) print '(" nrot,mysize =",2i6)', nrot,mysize
     if(ifmpi) call mpi_abort(MPI_COMM_WORLD,icode,ierr)
     stop
  endif
  lrot = nrot/2
  smooth = .true.
  if(smooth) then
     !	angular smoothing of radiation field in grid 9.  ntsm = 2 in grids 1-8
     ntsm = 2
     !	radial smoothing hardwired for nrsm = 2 if set > 1
     nrsm = 2
  else
     ntsm = 1
     nrsm = 1
  endif
  smooth = .false.  !  turn off extra angular smoothing in grid 9
  !	wavenumber (>0) or grain type (<0) for ggfs plots
  iupl = -6
  !	outermost grid in cubes
  ngc = ng/2
  !	grid for ggfs plots
  igpl = 6
  !	parameter (mc = 256)
  !	parameter (mmap = 1024)
  nc = mc

  !	dv isn''t in common.  put it in dw
  dw = dv
  call readparms
  dv = dw

  !	stellar effective temperature
  if(xlstar*rstar.gt.zero) then
     tstar = 5.8d+03*(xlstar/(rstar/rsun)**2)**quart
  elseif(xlstar*tstar.gt.zero) then
     rstar = rsun*sqrt(xlstar)*(5.8d+03/tstar)**2
  elseif(rstar*tstar.gt.zero) then
     xlstar = (tstar/5.8d+03)**4*(rstar/rsun)**2
  endif
  if(tburn.le.zero) then
     tburn = tstar
     xburn = one
  endif
  !	T s.t. kT = G Mstar Mmol / Rstar
  tgrav = 6.67d-08*xmstar*xmsun*xmg/(rstar*bk)
  !	effective temperature including UV excess
  teff = tstar*(one+xuv)**quart
  !	hot dust temperature at rstar
  tsurf = teff/(two**0.4)
  gmmdot = 8.36d+51*xmstar*xmdot
  wmdot = wmdot*xmsun/(xmg*secyr*fpi)
  if(doprint.and.(wmdot.gt.zero).and.(nt.lt.nnt)) &
       print '("Warning: nt must = nnt if wmdot > 0")'
  !	viscosity parameter for dust settling
  avisc = avisc*xmg/rhod
  !	x-ray luminosity of star * heating efficiency
  pxr = 0.4*pxr*xlstar*xlsun
  !	orbital speed at 1 AU (scale as r^-1/2)
  vorb = 30.*vkms*sqrt(xmstar)
  !	vterm may be hardwired = 0
  vterm = zero*vkms
  iwterm = nw2+one+vterm/dv
  !	wind speed
  vwind = vwind*vkms
  !	Gaussian resolution HW1/e in pixels
  dsm = one*vkms/dv
  nsm = ten*dsm
  nsm = min(32,nsm)
  dw = wec*dv
  ngr = ng+nn9
  xn9 = nn9
  xnn9 = xn9*xn9
  ng9 = ng+1
  nr9 = nn9*nr
  !	cell size on grid 0; dr = dr0*2**ig
  dr0 = rgrid1/(2*nr)
  !	cell size on expanded grid 1
  dr9 = two*dr0/xn9
  nr2 = nr/2
  nt8 = nt-nt/nn9
  dcost = one/nnt
  dcos9 = dcost/xn9
  coswind = min(coswind,(nt*dcost))
  thwind = acos(coswind)
  dcrot = one/nrot
  !	calculate lower half of grid and mirror
  bipolar = ((vterm.eq.zero).and.(wmdot.eq.zero))
  nx9 = nn9*nx
  ny = nx
  !	set nz = 2*nr so dz = dr
  nz = 2*max(nr,nnt)
  !	need greater nz with inner disk?
  !        if(sigma1.gt.zero) nz = 2*nz
  nz9 = nn9*nz
  xnx = nx
  xnz = nz
  !	rho-z grid size
  nrz = 4*nr
  !	convert sigma0 (roughly) to pmid0
  sigma0 = sigma0/xmg
  sigma1 = sigma1/xmg
  tmid0 = 3.00d+02
  hh2 = (tmid0/tgrav)*(r0**3/rstar)
  pmid0 = tmid0*sigma0/sqrt(tpi*hh2)
  pmid1 = tmid0*sigma1/sqrt(tpi*hh2)
  !	pmid = (pmid0/((r0/r)**qcol+(r/r0)**pcol)
  !		+pmid1/(r0/r)**ocol)*sexp(-r/r1)
  !	inner and outer edge of calculated disk
  pmin = one
  if(sigma1.gt.zero) then
     rin = rstar
  elseif(qcol.gt.zero) then
     rin = max(rin,r0*(pmin/pmid0)**(one/qcol))
  else
     rin = max(rstar,rgrid1/1.6d+01)
  endif
  rout = rgrid1*two**(ng-1)
  if(r0*pcol.gt.zero) then
     rmax = rout
     do iit = 1,4
        rmax = rmax*slog((pmid0/pmin)*(r0/rmax)**pcol)
     enddo
     rout = min(rout,rmax)
  endif
  if(mit.eq.0) lte = .true.

  npl = lrot
  if(npl.gt.mu) npl = npl/2
  if((ngr.gt.mg).or.(nr.gt.mr).or.(nt.gt.mt).or.(nrot.gt.2*mt) &
       .or.(npl.gt.mu)) then
     if(doprint) then
        print '(" array out of bounds",10i6,2i8)', &
             ngr,mg,nr,mr,nt,mt,nrot,mt,nz,nt*ng*nr2,mmap
        if(ifmpi) call mpi_abort(MPI_COMM_WORLD,icode,ierr)
        stop
     endif
  endif
  if(ifmpi.and.doprint &
       .and.(mod(nrot,mysize).ne.0)) then
     print '(" nrot must be a multiple of mysize",2i8)', &
          nrot,mysize
     if(ifmpi) call mpi_abort(MPI_COMM_WORLD,icode,ierr)
     stop
  endif

  !	pass parameters to startgr
  call initgr(dr0,dr9,dcost,dcos9,nr,nr9,ng9,nt,nt8)

  dx0 = (two*nr*dr0)/xnx
  dx9 = two*dx0/xn9
  dz0 = xnx*dx0/xnz
  dz9 = two*dz0/xn9
  nx2 = nx/2
  ny2 = ny/2
  nz2 = nz/2
  !	typical values
  tgi = 300.
  hh2 = (tgi/tgrav)*(r0**3/rstar)
  dens = sigma0/sqrt(tpi*hh2)
  if(doprint) then
     print '(" H2 dens, mass column, scale height at",f8.3, &
          " AU =",1p,3e9.2)', &
          r0/au,dens,sigma0*xmg,sqrt(hh2)/au
     print '(" stellar M, L, T, R, dMdt =", &
          2f8.3,f8.0,f8.2,1p,e9.2)', &
          xmstar,xlstar,tstar,rstar/rsun,xmdot
     print '(" vorb, vturb, vwind, vstep =",f8.1,4f8.3)', &
          vorb/vkms,dvturb0/vkms,dvturb1/vkms,vwind/vkms,dv/vkms
     print '(" inner xyz grid:",i3," x",f10.5," to",f10.4," AU")', &
          nx9,dx9/au,nx9*dx9/(two*au)
     print '(" outer xyz grid:",i3," x",f10.4," to",f10.3," AU")', &
          nx,(two**ng)*dx0/au,(two**(ng-1))*nx*dx0/au
     print '(" calculation limits (AU):",2f10.3)', &
          rin/au,rout/au
  endif
  if(doplot) then
     write(16,'(" H2 dens, mass column, scale height at",f8.3, &
          " AU =",1p,3e9.2)') &
          r0/au,dens,sigma0*xmg,sqrt(hh2)/au
     write(16,'(" stellar M, L, T, R, dMdt =", &
          2f8.3,f8.0,f8.2,1p,e9.2)') &
          xmstar,xlstar,tstar,rstar/rsun,xmdot
     write(16,'(" vorb, vturb, vwind, vstep =",f8.1,3f8.3)') &
          vorb/vkms,dvturb0/vkms,dvturb1/vkms,vwind/vkms,dv/vkms
     write(16,'(" inner xyz grid:",i3," x",f10.5, &
          " to",f10.4," AU")') &
          nx9,dx9/au,nx9*dx9/(two*au)
     write(16,'(" outer xyz grid:",i3," x",f10.4, &
          " to",f10.3," AU")') &
          nx,(two**ng)*dx0/au,(two**(ng-1))*nx*dx0/au
  endif
  astar = pi*(rstar/(dx0*two**ng))**2
  dxstar = rstar/four
  gsum = zero
  do ix = 1,4
     x = dxstar*(ix-half)
     gwt = sqrt(one-(x/rstar)**2)
     gsum = gsum+two*gwt
  enddo
  bstar = astar/gsum

  !	set up dust arrays
  tsubli = tsubl*max(one,pmid0)**gsubl
  call dustinit(xc,xsi,ac,asi,tuv,xuv,abss,tsubli)
  !	abss is the fraction of the incident starlight absorbed by the disk
  !	after multiple scatterings
  fwmx = zero
  sumfs = zero
  do iu = 1,nu
     busdud = bus(iu)*dud(iu)
     if(busdud.gt.fwmx) fwmx = busdud
     sumfs = sumfs+busdud
     gg(iu,1,1,1) = zero
     opa(iu,1,1,1) = zero
  enddo
  fwmx = astar*fwmx
  !	print typical numbers
  if(doprint) then
     xlvis = sigsb*tstar**4*fpi*rstar**2/xlsun
     xluv = xuv*xlvis
     xlphot = sumfs*pi*fpi*rstar**2/xlsun
     xlaccr = gmmdot/(two*rin*xlsun)
     print '(" Lvis,Luv,Lphot,Laccr(rin,rstar) =",5f8.3)', &
          xlvis,xluv,xlphot,xlaccr,xlaccr*(rin/rstar)
     !	heating and cooling power per atom at r0
     colin = 1.0d+22
     colup = 1.0d+21
     xco = xco0
     xwat = xwat0
     cgas = cooling(dens,tgi,1,1,1)
     popsum = zero
     do ia = 1,na
        popa = popd(ia)*pi*ad(ia)**2
        popsum = popsum+popa
     enddo
     acgd = four*dens**2*popsum*sqrt(bk*tgi/xmg)*acom*2.5*bk
     hxr = (pxr/(fpi*r0**2))*((axr/two)/(axr*colin/two+one)**2)
     haccr = gmmdot/(fpi*r0**3*sigma0)
     print '(" gas heating and cooling at r0:",1p,4e10.2)', &
          hxr,haccr,cgas,acgd
  endif

!!$ STH: BEGIN CASE FOR REUSE
!!$ Write arrays when importing abundances with reuse = .TRUE.
!!$ Currently not using reuse
  if(reuse) then
     lw = nu
     if(doprint) then
        print '(" Enter molecular abundance file name: "$)'
        read '(a16)', chemfile
        if(index(chemfile,' ').lt.2) chemfile = 'none'
     endif
     if(ifmpi) call mpi_bcast(chemfile,16,MPI_CHARACTER, &
          0,MPI_COMM_WORLD,ierr)
     if(doprint) print '(" reading saved disk model")'
     call readmodel(chemfile,xburn)
     reuse = (index(chemfile,'none').lt.1)
     if(doplot) then
        print '(" plotting log_10(gas density)")'
        call plotcon(dg,.true.,'')
        call waitasec(wait,2)
        print '(" plotting log_10(gas temperature)")'
        call plotcon(tg,.true.,'')
        call waitasec(wait,2)
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              do it = 1,lt
                 dm(it,ir,ig) = xmol*dl(8,it,ir,ig)
              enddo
           enddo
        enddo
        call copyarr(dm)
        print '(" plotting log_10(mol abundance)")'
        call plotcon(dm,.true.,'')
        call waitasec(wait,2)
     endif ! if (doplot)
     goto 300
  endif ! if (reuse)
!!$ STH: END CASE FOR REUSE

  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)
  if(doprint) print '(" calculate C&G disk model")'

  !	initialize taufac and condens
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = 1,lr
        do it = 1,nt
           opl(ml,it,ir,ig) = one
           do ia = 1,na
              condens(ia,it,ir,ig) = zero
           enddo
        enddo
     enddo
  enddo

!!$ STH: BEGIN C&G DISK CALCULATION (Chiang and Goldreich, 1997)
  !	calculate sublimation front and C&G disk structure
  !	don''t know how to farm out
  ll = 1
  lw = 1
  ffstar = one
  nit = 0
  ustar = four*tstar/hck
  iustar = slog(ustar/ud(1))/slog(ud(2)/ud(1))+1.5
  iustar = min(nu,max(1,iustar))
  ias1 = na/2+1
  ias = slog(asi/ad(ias1))/slog(ad(ias1+1)/ad(ias1))+1.5
  ias = min(na,max(ias1,ias))
  lastit = .false.
  xmdisk = zero
  ginv = one/gsubl
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     if(igr.le.1) then
        ifrim = .false.
        rim = rout
        rim0 = rout
        rphot = rout
        rimw = rout
        inwind = (wmdot*vwind.ne.zero)
        grim = one
        frat = one
        graz = one
        zrim = zero
        zphot = zero
        zrlast = zero
        do it = 1,nt
           do iu = 1,nu
              taud(iu,it) = zero
           enddo
           dtac4(it) = zero
        enddo
        itwind = nt
        itrim = nt
     endif
     do ir = kr,lr
        r = dr*(ir-half)
        it = nt
        if(r.le.rstar) then
           r = rstar
           ostar = one
        elseif(r.lt.(hun*rstar)) then
           ostar = (one-sqrt(one-(rstar/r)**2))/two
        else
           ostar = quart*(rstar/r)**2
        endif
        !	wind density at r  (wmdot is mols/sec/fpi)
        if(wmdot*vwind.ne.zero) then
           dgw = wmdot/(vwind*r**2)
        else
           dgw = zero
        endif
        !	wind ram pressure
        pram = dgw*xmg*vwind**2/bk
        if((r.gt.rin).and.(r.lt.rout)) then
           tst4 = ostar*teff**4
           tir4 = graz*abss*tst4/two
           tir = tir4**quart
           !	use tir (leaving out dtac4) for calculation of sigma and graz?
           !	and just use first term in pmid for sigma so heating doesn't blow up
           hr2 = (tir/tgrav)*(r/rstar)
           hh2 = hr2*r**2
           sigma = (pmid0*(r0/r)**pcol/tir)*sqrt(tpi*hh2)
           sigma = max(sigma,1.0d+18)
           pmid = pmid0/((r0/r)**qcol+(r/r0)**pcol) &
                +pmid1/(r/r0)**ocol
           if(r1.gt.zero) pmid = pmid/sexp(r/r1)
           tsubli = tsubl*max(one,pmid)**gsubl
           frat0 = frat
           if(r.lt.rim0) then
              !	find sublimation rim without reflected light
              fab = zero
              fem = zero
              do iu = 1,nu
                 phabdud = phab(iu,ias)*dud(iu)
                 fab = fab+bus(iu)*ostar*phabdud
                 fem = fem+bw(ud(iu),tsubli)*phabdud
              enddo
              frat = fab/fem
              if(frat.lt.one) rim0 = r-(one-frat)/(frat0-frat)*dr
              prim = two*pmid
           elseif(r.lt.rim) then
              !	find sublimation rim with reflected light
              fab = zero
              fem = zero
              do iu = 1,nu
                 phabdud = phab(iu,ias)*dud(iu)
                 fab = fab+(bus(iu)+rebus(iu))*ostar*phabdud
                 fem = fem+bw(ud(iu),tsubli)*phabdud
              enddo
              frat = fab/fem
              if(frat.lt.one) then
                 !	found rim.  calculate trim s.t. fab = fem and prim
                 rim = r-(one-frat)/(frat0-frat)*dr
                 trim = tsubli*frat**quart
                 do iit = 1,4
                    fem = zero
                    do iu = 1,nu
                       phabdud = phab(iu,ias)*dud(iu)
                       fem = fem+bw(ud(iu),trim)*phabdud
                    enddo
                    frat = fab/fem
                    trim = trim*frat**quart
                 enddo
                 trim = max(tsubl,trim)
                 prim = (trim/tsubl)**ginv
                 ifrim = .true.
              else
                 prim = two*pmid
              endif
           else
              !	beyond rim.  calculate trim s.t. fab = fem and prim
              !	including effect of rim grazing angle
              rlast = r-dr
              if((rlast.lt.rim).or.(zrim.eq.zero)) then
                 grim = one
              elseif(itrim.gt.1) then
                 grim = zrim/(two*rlast*slog(rlast/rim))
                 grim = grim/sqrt(one+grim**2)
                 !	assume grim = const when rim is outside of grid
              endif
              frat = (rlast/r)**2
              trim = trim*frat**quart
              fab = zero
              do iit = 1,2
                 fem = zero
                 do iu = 1,nu
                    phabdud = phab(iu,ias)*dud(iu)
                    if(iit.eq.1) &
                         fab = fab+(bus(iu)+grim*rebus(iu))*ostar*phabdud
                    fem = fem+bw(ud(iu),trim)*phabdud
                 enddo
                 frat = fab/fem
                 trim = trim*frat**quart
              enddo
              trim = max(tsubl,trim)
              prim = (trim/tsubl)**ginv
           endif
           if(ifrim.and.(r.lt.rphot).and.(taud(iuv,nt).gt.one)) then
              dtaudr = sqrt(opa(iuv,nt,ir-1,ig) &
                   *(opa(iuv,nt,ir-1,ig)+sca(iuv,nt,ir-1,ig)))
              rphot = r-(taud(iuv,nt)-one)/dtaudr
           endif
           rlast = r-dr
           !	calculate graz from last zphot
           if((rlast.lt.rphot).or.(zphot.eq.zero)) then
              graz = one
           else
              graz = zphot/(two*rlast*slog(rlast/rphot))
              graz = graz/sqrt(one+graz**2)
           endif
           !	find sublimation rim in wind
           if((dgw.gt.zero).and.(r.lt.rimw)) then
              tsublw = tsubl*(dgw*tsubl)**gwind
              fab = zero
              fem = zero
              do iu = 1,nu
                 phabdud = phab(iu,ias)*dud(iu)
                 fab = fab+bus(iu)*ostar*phabdud
                 fem = fem+bw(ud(iu),tsublw)*phabdud
              enddo
              if(fab.lt.fem) rimw = r-dr/two
           endif
        else
           sigma = zero
           pmid = zero
           prim = zero
           tsubli = tsubl
           graz = one
        endif
        tdrad = teff*ostar**fifth
        tst4 = ostar*teff**4
        tir4 = graz*abss*tst4/two
        tir = tir4**quart
        tmid = tir
        hr2 = (tir/tgrav)*(r/rstar)
        hh2 = hr2*r**2

        !	C&G interior temperature and density
        !	iterate at each r
        nit = 0
100     nit = nit-1
        pres = pmid
        ddfac = zero
        faccr = zero
        inwind = (pmid.le.pram).and.(itwind.eq.nt)
        !	step up from midplane
        do it = nt,1,-1
           costh = dcosth*(nt-it+half)
           sinth = sqrt(one-costh**2)
           if(costh.gt.coswind) inwind = .true.
           z = r*costh
           dz = r*dcosth
           !	start with temperature from last iteration or from neighboring cell
110        if(nit.lt.(-1)) then
              tgi = tg(it,ir,ig)
              tdi = td(it,ir,ig)
           elseif(ir.gt.kr) then
              tgi = tg(it,ir-1,ig)
              tdi = td(it,ir-1,ig)
           elseif(igr.gt.1) then
              tgi = tg(it,lr,ig-1)
              tdi = td(it,lr,ig-1)
           else
              tgi = tstar
              tdi = tstar
           endif
           tgi0 = tgi
           if(r.lt.rin) then
              dens = zero
              pres = zero
              ddfac = zero
              tsubli = tsubl
              tdhot = tsubli/two**quart
              do iu = 1,nu
                 gg(iu,it,ir,ig) = ostar*bus(iu)
              enddo
           elseif(inwind) then
              dens = dgw
              pres = dens*tgi
              ddfac = zero
              tsubli = tsubl*max(pres,one)**gsubl
              tdhot = tsubli/two**quart
              do iu = 1,nu
                 trans = sexp(-taud(iu,it))
                 gg(iu,it,ir,ig) = &
                      bw(ud(iu),tdhot)*(tir4/tdhot**4)*trans/two &
                      +ostar*(bus(iu)+graz*rebus(iu))*trans
              enddo
              if(r.gt.rimw) then
                 do ia = 1,na
                    condens(ia,it,ir,ig) = one
                 enddo
              endif
           else
              hr2 = (tgi/tgrav)*(r/rstar)
              hh2 = hr2*r**2
              !	pressure change in half cell
              gaus = sexp(-(z*dz)/(two*hh2))
              !	pressure at center of cell
              pres = pres*gaus
              if(badnum(pres).or.(pres.lt.one)) pres = zero
              if((it.le.itwind).and.(pres.lt.pram)) then
                 inwind = .true.
                 itwind = it
                 goto 110
              endif
              if((it.eq.itrim).and.(pres.gt.prim)) itrim = it-1
              if(it.gt.itrim) then
                 do ia = 1,na
                    condens(ia,it,ir,ig) = one
                 enddo
              endif
              !	density at center of cell
              dens = pres/tgi
              !	dust density decrease exponential factor for a = 1 cm
              !	(avisc has been multiplied by xmg/rhod)
              if((avisc.gt.zero).and.(dens.gt.zero)) then
                 ddfac = ddfac+z*dz/(avisc*hh2*sqrt(hh2)*dens)
              elseif((avisc.lt.zero).and.(dens.gt.zero)) then
                 avist = -avisc*min(ten,max(one,tgi/hun))**4
                 ddfac = ddfac+z*dz/(avist*hh2*sqrt(hh2)*dens)
              else
                 ddfac = zero
              endif
              !	accumulated heat flux from viscous heating
              if(sigma.gt.zero) then
                 faccr = faccr+gmmdot*dens*dz/(fpi*sigma*r**3)
              endif
              !	add accretion heating to heating by hot dust emission
              !	tir4 is from midplane calculation
              !	dtac4 is from previous r or previous iteration
              tir = (tir4+dtac4(it))**quart
              tsubli = tsubl*max(pres,one)**gsubl
              tdhot = tsubli/two**quart
              tir = min(tir,tsubli)
              do iu = 1,nu
                 transr = sexp(-taud(iu,it))
                 trans = sexp(-taud(iu,it)*graz)
                 !	does this include downward scattered light?
                 gg(iu,it,ir,ig) = bw(ud(iu),tir)*(one-trans/two) &
                      +bw(ud(iu),tdhot)*(tir4/tdhot**4)*trans/two &
                      +ostar*(bus(iu)*transr+graz*rebus(iu)*trans)
              enddo
           endif  !  inwind
           taucont = taud(iuv,it)
           dg(it,ir,ig) = dens
           dd(it,ir,ig) = ddfac
           if(ir.gt.kr) then
              colin = colr(it,ir-1,ig)
              colup = colz(it,ir-1,ig)
           elseif(igr.gt.1) then
              colin = colr(it,lr,ig-1)
              colup = colz(it,lr,ig-1)
           else
              colin = zero
              colup = zero
           endif
           !	should use better chemistry
           xwat = xwat0*sexp(-(tfrwat/tdi)**10)
           xco = xco0*sexp(-(tfrco/tdi)**10)
           !	enhance CO where carbon is burned
           if((xburn.gt.one).and.(tburn.gt.one)) &
                xco = xco*(xburn+(one-xburn)*sexp(-(tgi/tburn)**10))
           if(taucont.le.zero) then
              xwat = xwat/hun
              xco = xco/hun
           endif
           !	calculate dust temperatures and opacities
           call gastemp(it,ir,ig,iamax,tsubli,tgi,tdi,hcgas,lastit)
           !	prevent cold layer on shadowed surface
           !	where there's cooling but no heating
           tgi = max(tmid,tgi)
           dens = pres/tgi
           if(dens.lt.small) then
              dens = zero
              pres = zero
           endif
           if(.not.inwind) then
              !	calculate Planck mean opacity (should use Rosseland?)
              opapl = zero
              bwsum = zero
              do iu = 1,nu
                 opai = opa(iu,it,ir,ig)
                 if(opai.le.zero) goto 120
                 bwdud = bw(ud(iu),tgi)*dud(iu)
                 if(iu.eq.1) bwdud = two*bwdud
                 opapl = opapl+bwdud/opai
                 bwsum = bwsum+bwdud
              enddo
              opapl = bwsum/opapl
              if(badnum(opapl)) then
                 if(doprint) print '("at",3i6," opapl =",1p,5e10.2)', &
                      it,ir,ig,opapl,bwsum,tgi,bwdud,opai
                 opapl = zero
              endif
120           dtac4(it) = thrq*faccr*opapl*dz/sigsb
              hr2 = (tgi/tgrav)*(r/rstar)
              hh2 = hr2*r**2
              !	undo first guess at pressure change
              pres = pres/gaus
              !	pressure change in full cell
              gaus = sexp(-(z*dz)/hh2)
              !	pressure at top of cell
              pres = pres*gaus
              if(pres.lt.one) pres = zero
           endif
           !	values at cell center
           dg(it,ir,ig) = dens
           dd(it,ir,ig) = ddfac
           tg(it,ir,ig) = tgi
           td(it,ir,ig) = tdi
           taufac = opl(ml,it,ir,ig)
           colr(it,ir,ig) = colin+taufac*dens*dr
           sumcon = zero
           do ia = 1,na
              sumcon = sumcon+condens(ia,it,ir,ig) &
                   *sexp(-ad(ia)*ddfac)*taufac
           enddo
           !              dm(it,ir,ig) = sumcon
           !              dm(it,ir,ig) = iamax
           !              dm(it,ir,ig) = tdi/tsubli
           !              dm(it,ir,ig) = sumcon*dens*(r/au)**2
           dm(it,ir,ig) = max(zero,slog10(pres))
        enddo  !  it
        
        !	save tmid for next iteration
        tmid = (9.*tg(nt,ir,ig)-tg(nt-1,ir,ig))/8.
        !	integrate dtac4 and colz down through the disk
        dtaci = faccr/(two*sigsb)
        dtac4(1) = dtaci
        colup = zero
        !	hh2 and z should still be known from last it (1)
        if(ig.eq.ng9) colup = dg(1,ir,ig)*(hh2/z)
        colz(1,ir,ig) = colup
        do it = 2,nt
           dtaci = dtaci+dtac4(it)
           dtac4(it) = dtaci
           !	leave out opl(ml) since stretching is radial
           colup = colup+dg(it,ir,ig)*dz
           colz(it,ir,ig) = colup
        enddo
        if(nit.gt.-kit) goto 100
        !	just passed rim
        if(doprint.and.(r.gt.rim).and.(r.lt.rim+dr)) then
           tdi = td(nt,ir,ig)
           dens = dg(nt,ir,ig)
           pres = dens*tdi
           tsubli = tsubl*max(pres,one)**gsubl
           print &
                '(" found sublimation rim at",3f8.4,2f8.2,1p,e10.2)', &
                rim/au,rim0/au,rin/au,tsubli,tdi,dens
        endif

        xmdisk = xmdisk+fpi*r*dr*colup
        iw = ir+(ig-1)*nr/2
        if((ig.le.ng).and.(iw.ge.1).and.(iw.le.mw)) then
           smax = 1.0d+04
           spec(iw,4) = slog10(max(one,min(smax,tg(nt,ir,ig))))
           spec(iw,16) = spec(iw,4)
        endif
        if(r.gt.rim) then
           zphot = zero
           do it = 1,nt
              do iu = 1,nu
                 opai = opa(iu,it,ir,ig)
                 if(opai.gt.zero) then
                    taud(iu,it) = taud(iu,it) &
                         +sqrt(opai*(opai+sca(iu,it,ir,ig)))*dr
                 endif
              enddo
              taulast = taucont
              taucont = taud(iuv,it)
              if((zphot.eq.zero).and.(taucont.gt.one)) then
                 dit = (taucont-one)/(taucont-taulast)
                 zphot = r*dcosth*(nt-it+half+dit)
              endif
           enddo
           zrim = r*dcosth*(nt-itrim)
        endif
     enddo  !  ir
     if(ig.lt.ng) then
        !	I don''t know why this is needed
        tg(nt,nr/2,ig+1) = (tg(nt,nr-1,ig)+tg(nt,nr,ig))/two
        td(nt,nr/2,ig+1) = (td(nt,nr-1,ig)+td(nt,nr,ig))/two
     endif
  enddo  !  igr
!!$ STH: END C&G DISK CALCULATION (Chiang and Goldreich 1997)
!!$ TODO: make c&g calculation into a subroutine in module

  call copyarr(dm)
  call copyarr(dg)
  call copyarr(dd)
  call copywta(tg,dg)
  call copywta(td,dg)
  call copyarrr(opl,ml,ml)
  call copyarrr(opa,mu,nu)
  call copyarrr(sca,mu,nu)
  call copyarrr(swd,mu,nu)
  call copyarrr(gg,mu,nu)

!!$ STH: BEGIN PLOT AND WRITE OF C&G DISK STRUCTURE CALCULATION
!!$ TODO: Write out C&G disk structure to test convergence
!!$ Commented out with !!$CG
!!$ TODO: make option 'printcg'
!!$ TODO: modularize printing of arrays
  if(doprint) then
     print '(" disk mass:",1p,e10.2)', xmdisk*xmg/xmsun
     print '(" midplane sublimation, photosphere radii:", &
          2f10.4)', rim/au,rphot/au
     if(rphot.gt.rgrid1) &
          print '("Warning: photosphere outside of grid 1")'
  endif
  if(doplot) then
     write(16,'(" midplane sublimation, photosphere radii:", &
          2f10.4)') rim/au,rphot/au
  endif

  !	plot mean intensity / stellar on xy grid
  if(doplot) then
     print '(" plotting settling*condensation*taufac")'
     !          print '(" plotting largest sublimating grain")'
     !          print '(" plotting dust temperature / sublimation")'
     !          print '(" plotting dust density * r^2")'
     call plotcon(dm,.false.,'')
!!$CG!!$ shows settling; settling = 0...1 dust-gas ratio to cononical dust-gas ratio; condense = 0...24 grain species; taufac to expand edge of chaning optical depth
     call waitasec(wait,2)
     !	plot dust heating image
     print '(" plotting dust heating radiation / stellar")'
     if(rim.lt.rgrid1) then
        call plotggfs(gg,ng9,iupl)
        call waitasec(wait,2)
     endif
     call plotggfs(gg,igpl,iupl)
     call waitasec(wait,2)
     !	plot gas density and dust temperature
     print '(" plotting log_10(hydrogen density)")'
     call plotcon(dg,.true.,'')
     call waitasec(wait,2)
!!$CG!!$ units are particles / cm^3. includes all particles, not just H2, although disk is dominated by H2
     print '(" plotting C&G gas temperature")'
     call plotcon(tg,.false.,'')
!!$CG!!$ STH: Write out cooling and heating arrays wherever tg is tg is written out. Units in erg s^-1 particle^-1
  endif ! if(doplot)
!!$ STH: END PLOT AND WRITE OF C&G DISK STRUCTURE CALCULATION

  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)
  lw = nu
  sumfs = sumfs*astar
  !          +gmmdot/(two*max(rim,r0)*fpi*(dx0*two**ng)**2)

  nit = 0
  moltype = -abs(moltype)
  ffstar = one
  hcsum = zero

!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!!$ STH: BEGIN ITERATIVE CALCULATIONS OF DISK STRUCTURE
  !	loopback point for dust radiative transfer !!$ and dust structure
200 nit = nit+1
  lastit = (nit.eq.lit)

  if(doprint) print '(" calculate hydro equil disk structure")'
  !	calculate hydro equil disk structure with new temperatures
  !	don''t know how to farm out
  xmdisk = zero
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     drho = dr/four
     dz = dr/four
     lp = 4*lr
     kp = lp/2+1
     lz = 4*nr
     kz = lz/2+1
     drig = dr
     lrig = lr
     rmx = (lr-half)*dr
     if(igr.le.1) cosw = zero
     do ip = 1,lp
        rho = (ip-half)*drho
        !	calculate midplane temp, dens, pres
        r = rho
        tmid = (9.*tg(nt,ip,ig)-tg(nt-1,ip,ig))/8.
        hh2 = (tmid/tgrav)*(r**3/rstar)
        if((r.gt.rin).and.(r.lt.rout)) then
           pmid = pmid0/((r0/r)**qcol+(r/r0)**pcol) &
                +pmid1/(r/r0)**ocol
           if(r1.gt.zero) pmid = pmid/sexp(r/r1)
        else
           pmid = zero
        endif
        dgmid = pmid/tmid
        if(badnum(dgmid)) dgmid = zero
        if(wmdot*vwind.ne.zero) then
           dgw = wmdot/(vwind*r**2)
        else
           dgw = zero
        endif
        pram = dgw*xmg*vwind**2/bk
        inwind = (pram.gt.pmid).and.(cosw.eq.zero)
        !	solve eqn of hydro equil in cylindrical coords
        pres = pmid
        ddfac = zero
        colup = zero
        !	use nr here b/c nz9 = nr, not nr9
        do iz = 1,lz
           z = (iz-half)*dz
           if((ig.eq.1).and.(iz.le.(lz/nn9))) then
              !	interpolate from grid 9 onto grid 1
              jg = ng9
              jp2 = ip*nn9
              jp1 = jp2-nn9+1
              jz2 = iz*nn9
              jz1 = jz2-nn9+1
              sumnpz = xnn9
              sumtg = zero
              sumdg = zero
              sumdd = zero
              do jp = jp1,jp2
                 do jz = jz1,jz2
                    sumtg = sumtg+tgz(jz,jp,jg)
                    sumdg = sumdg+dgz(jz,jp,jg)
                    sumdd = sumdd+ddz(jz,jp,jg)
                 enddo
              enddo
              tgi = sumtg/sumnpz
              dens = sumdg/sumnpz
              ddfac = sumdd/sumnpz
              !	want pres at top of cell
              jz1 = jz2-1
              jp1 = (jp1+jp2)/2
              jp2 = jp1+1
              pres1 = (dgz(jz1,jp1,jg)+dgz(jz1,jp2,jg)) &
                   *(tgz(jz1,jp1,jg)+tgz(jz1,jp2,jg))/four
              pres2 = (dgz(jz2,jp1,jg)+dgz(jz2,jp2,jg)) &
                   *(tgz(jz2,jp1,jg)+tgz(jz2,jp2,jg))/four
              pres = (3.*pres2-pres1)/two
           elseif((igr.gt.1).and.(ip.lt.kp).and.(iz.lt.kz)) then
              !	interpolate from grid ig-1 for inner half of grid
              jg = ig-1
              jp2 = 2*ip
              jp1 = jp2-1
              jz2 = 2*iz
              jz1 = jz2-1
              sumnpz = four
              sumtg = zero
              sumdg = zero
              sumdd = zero
              do jp = jp1,jp2
                 do jz = jz1,jz2
                    sumtg = sumtg+tgz(jz,jp,jg)
                    sumdg = sumdg+dgz(jz,jp,jg)
                    sumdd = sumdd+ddz(jz,jp,jg)
                 enddo
              enddo
              tgi = sumtg/sumnpz
              dens = sumdg/sumnpz
              ddfac = sumdd/sumnpz
              pres1 = (dgz(jz1,jp1,jg)+dgz(jz1,jp2,jg)) &
                   *(tgz(jz1,jp1,jg)+tgz(jz1,jp2,jg))/four
              pres2 = (dgz(jz2,jp1,jg)+dgz(jz2,jp2,jg)) &
                   *(tgz(jz2,jp1,jg)+tgz(jz2,jp2,jg))/four
              pres = (3.*pres2-pres1)/two
           else
              r = sqrt(rho**2+z**2)
              costh = z/r
              xit = nt-costh/dcosth+half
              if(r.gt.rmx) then
                 !	can''t be more than one grid out from ig
                 if(igr.eq.0) then
                    jg = 2
                    dr = four*dr0
                    lr = nr
                    xit = nt-costh/dcost+half
                 elseif(igr.lt.ng) then
                    jg = igr+1
                    lr = lrig
                    dr = two*drig
                 else
                    jg = ig
                    lr = lrig
                    dr = drig
                 endif
              elseif(xit.lt.half) then
                 !	assume we''re in grid 9
                 jg = 1
                 dr = two*dr0
                 lr = nr
                 xit = nt-costh/dcost+half
              else
                 jg = ig
                 lr = lrig
                 dr = drig
              endif
              xir = r/dr+half
              ir = xir
              ir = max(1,min(lr-1,ir))
              jr = ir+1
              dir = xir-ir
              !	don''t extrapolate
              dir = max(zero,min(one,dir))
              djr = one-dir
              it = xit
              it = max(1,min(nt-1,it))
              jt = it+1
              dit = xit-it
              dit = max(zero,min(one,dit))
              djt = one-dit
              tgi = djr*(djt*tg(it,ir,jg)+dit*tg(jt,ir,jg)) &
                   +dir*(djt*tg(it,jr,jg)+dit*tg(jt,jr,jg))
              taufac = djr*(djt*opl(ml,it,ir,jg)+dit*opl(ml,jt,ir,jg)) &
                   +dir*(djt*opl(ml,it,jr,jg)+dit*opl(ml,jt,jr,jg))
              !	if in stretched layer get tgi from looking ahead?
230           if(inwind) then
                 if(wmdot*vwind.ne.zero) &
                      dgw = wmdot/(vwind*r**2)
                 dens = dgw
                 pres = dens*tgi
                 ddfac = zero
              else
                 dens = pres/tgi
                 !	tgrav should change when H2 becomes H
                 hh2 = (tgi/tgrav)*(r**3/rstar)
                 !	dust density decrease exponential factor for a = 1 cm
                 if((avisc.gt.zero).and.(dens.gt.zero)) then
                    ddfac = ddfac+z*dz/(avisc*hh2*sqrt(hh2)*dens)
                 elseif((avisc.lt.zero).and.(dens.gt.zero)) then
                    avist = -avisc*min(ten,max(one,tgi/hun))**4
                    ddfac = ddfac+z*dz/(avist*hh2*sqrt(hh2)*dens)
                 else
                    ddfac = zero
                 endif
                 !	density change in half cell
                 gaus = sexp(-(z*dz)/(two*hh2))
                 !	pressure at center of cell
                 pres = pres*gaus
                 if(pres.lt.one) pres = zero
                 if((costh.gt.coswind).or. &
                      ((pres.lt.pram).and.(costh.ge.cosw))) then
                    inwind = .true.
                    cosw = max(cosw,costh-dz/r)
                    goto 230
                 endif
                 dens = pres/tgi
                 !	pressure at top of cell
                 pres = pres*gaus
              endif  !  inwind?
           endif  !  copy from inner grid
           tgz(iz,ip,ig) = tgi
           dgz(iz,ip,ig) = dens
           ddz(iz,ip,ig) = ddfac
           !	leave taufac in for calculation of mdisk
           colup = colup+taufac*dens*dz
        enddo  !  iz
        xmdisk = xmdisk+fpi*rho*drho*colup
     enddo  !  ip
  enddo  !  igr

  !	interpolate back onto trg grid
  !	could recalculate opl(ml) and condens here
  do igr = 0,ng
     !	should always be in rho-z grid ig
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     drho = dr/four
     dz = dr/four
     lp = 4*lr
     kp = lp/2+1
     lz = 4*nr
     kz = lz/2+1
     do ir = kr,lr
        r = dr*(ir-half)
        colup = zero
        do it = 1,nt
           costh = dcosth*(nt-it+half)
           z = r*costh
           rho = sqrt(r**2-z**2)
           xiz = z/dz+half
           iz = xiz
           iz = max(1,min(lz-1,iz))
           jz = iz+1
           diz = xiz-iz
           !	don''t extrapolate
           diz = max(zero,min(one,diz))
           djz = one-diz
           xip = rho/drho+half
           ip = xip
           ip = max(1,min(lp-1,ip))
           jp = ip+1
           dip = xip-ip
           dip = max(zero,min(one,dip))
           djp = one-dip
           dens = djp*(djz*dgz(iz,ip,ig)+diz*dgz(jz,ip,ig)) &
                +dip*(djz*dgz(iz,jp,ig)+diz*dgz(jz,jp,ig))
           ddfac = djp*(djz*ddz(iz,ip,ig)+diz*ddz(jz,ip,ig)) &
                +dip*(djz*ddz(iz,jp,ig)+diz*ddz(jz,jp,ig))
           dens = max(zero,dens)
           dg(it,ir,ig)   = dens
           dd(it,ir,ig)   = max(zero,ddfac)
!!$ STH: nGasArray = gas particle density for plotting. comment out for now
!!$           nGasArray(it,ir,ig) = dens
           dm(it,ir,ig)   = dens*(r/r0)**2
           if((ig.eq.ng9).and.(it.eq.1)) then
              hh2 = (tg(it,ir,ig)/tgrav)*(r**3/rstar)
              colup = dens*(hh2/z)
           endif
           !	leave out opl(ml) since stretching is radial
           colup = colup+dens*r*dcosth/sqrt(one-costh**2)
           colz(it,ir,ig) = colup
        enddo  !  it
     enddo  !  ir
  enddo  !  ig
  call copyarr(dg)
!!$ STH: nGasArray = gas particle density for plotting. comment out for now
!!$  CALL copyarr(nGasArray)
  call copyarr(dm)
  call copyarr(dd)
  call copyarr(colz)

  !	plot gas density
  if(doprint) print '(" disk mass:",1p,e10.2)', xmdisk*xmg/xmsun
  if(doplot) then
     print '(" plotting log_10(hydrogen density * r^2)")'
     monfile = ''
     if(nit.eq.(lit-1)) monfile = 'dens.con'
     call plotcon(dm,.true.,monfile)
     call waitasec(wait,2)

!!$ STH: On the last iteration, write out 2D arrays of disk structure
!!$ for plotting with IDL.        
!!$ call copyarr to communicate values between grid arrays

!!$ col dens = thickness*height, col dens falls like 1/r, and thickness falls as 1/r; plotted to make contours
     IF (lastit) THEN
        CALL copyarr(dg)
        PRINT *, "Writing GasDens.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = dg, &
             NumEltsD1In = SIZE(dg, 1), &
             NumEltsD2In = SIZE(dg, 2), &
             NumEltsD3In = SIZE(dg, 3), &
             FileNameOut = 'GasDens.out')
     END IF ! lastit
  endif
  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)

  !	dust radiative transfer

  if(doprint) then
     print '(/" calculate dust radiative transfer  nit =",i3)', &
          nit
  endif

  !	zero mean intensity arrays and spectrum
  call zerog(nu)
  do irot = 1,nrot
     do iu = 1,nu
        fw(iu,1,irot) = zero
     enddo
  enddo

  !	loop over ray directions (grid orientations), farming out
  do irot0 = 1,nrot,mysize
     irot = irot0+myrank
     crot = dcrot*(nrot-irot+half)
     rot = acos(crot)

     call zerof(nu)

     !	call outer grid routine, which loops over rays and calls inner grids
     !	stepd is called from grids to do dust radiative transfer
     !	and add contributions to mean intensity array
     call grid0(fwj,ny/2)

     !	add contribution to spectrum from +y and save in fw
     fwmn = two*fwj(1,1)*dud(2)/fwmx
     do iu = 1,nu
        fwiu = two*fwj(iu,1)
        fw(iu,1,irot) = fwiu
        fwnorm = fwiu*dud(iu)/fwmx
        fwj(iu,1) = slog10(max(fwmn,fwnorm))
     enddo
     fwj(1,1) = slog10(fwmn)

     !	plot images and spectrum
     if(doplot) then
        call movie(nc,1)
        call sleep(2)
        call movie(nc,2)
        call sleep(2)
        print '(" plotting log disk SED for irot =",i4)', irot
        jrot = (irot-1)/mysize+1
        call plotspec(fwj,mw,nu,1,jrot,0.,'')
     endif

     !	broadcast calculated spectra and add contributions to mean intensity
     if(ifmpi) then
        do irank = 0,mysize-1
           call mpi_bcast(fw(1,1,irot0+irank),nu, &
                MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
        enddo
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              call mpi_allreduce(MPI_IN_PLACE,fn(1,ir,ig),nt, &
                   MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
              call mpi_allreduce(MPI_IN_PLACE,ff(1,1,ir,ig),mu*nt, &
                   MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
           enddo
        enddo
     endif
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              gn(it,ir,ig) = gn(it,ir,ig)+fn(it,ir,ig)
              do iu = 1,nu
                 gg(iu,it,ir,ig) = gg(iu,it,ir,ig)+ff(iu,it,ir,ig)
              enddo
           enddo
        enddo
     enddo

     !	end loop over grid orientations
  enddo  !  irot

  !	fill in inner halves so I can smooth radially
  call copyarr(gn)
  call copyarrr(gg,mu,nu)
  !	divide gg and qq by gn and average if appropriate
  call ggavg(nu,ntsm,nrsm)
  call copyarrr(gg,mu,nu)
  !	plot gg before adding starlight
  if(doplot) then
     print '(" plotting disk light / stellar")'
     call plotggfs(gg,ng9,iupl)
     call waitasec(wait,2)
  endif

  !	radiative transfer of starlight (w/o sources)
  !	note: not doing star for nt < irot < nnt
  if(doprint) print '(" starlight radiative transfer")'
  !	first do nt rot steps for grids 1-ng
  call zerof(nu)
  dxstar = rstar/four
  idx = 4
  ix1 = nx9/2+1-idx
  ix2 = nx9/2+idx
  !	set iy to a value unused by dust rad xfer
  iy = nx9/2+1
  do irot0 = 1,nt,mysize
     irot = irot0+myrank
     crot = dcost*(nt-irot+half)
     if(abs(crot).gt.one) goto 240
     rot = acos(crot)
     if((irot.ge.1).and.(irot.le.nt)) then
        do iu = 1,nu
           fw(iu,2,irot) = zero
        enddo
     endif
     sumbg = zero
     do ix = ix1,ix2
        x = dxstar*(ix-nx9/2-half)
        gwt = sqrt(one-(x/rstar)**2)
        sumbg = sumbg+bstar*gwt
        !	start with stellar spectrum
        do iu = 1,nu
           fwj(iu,1) = bus(iu)
        enddo
        do igr = 1,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           if(igr.eq.1) then
              lz = nz9
              dz = dz9
              kz = lz/2+1+nint(rstar/dz)
           else
              lz = nz
              kz = 3*lz/4+1
              twig = two**ig
              dz = dz0*twig
           endif
           do iz = kz,lz
              call stepd(fwj,ix,iy,iz,ig)
           enddo
        enddo  !  igr
        !	sum outgoing stellar spectra in fw(iu,2,irot)
        if((irot.ge.1).and.(irot.le.nt)) then
           do iu = 1,nu
              fw(iu,2,irot) = fw(iu,2,irot)+bstar*gwt*fwj(iu,1)
           enddo
        endif
     enddo  !  ix
     if(ifmpi) then
        !	can''t use allgather since arrays aren''t contiguous
        !	but this caused computer to freeze if not all processors bcast
        do irank = 0,mysize-1
           irot = irot0+irank
           if((irot.ge.1).and.(irot.le.nt)) &
                call mpi_bcast(fw(1,2,irot),nu, &
                MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
        enddo
     endif
240 enddo  !  irot

  !	do finer rot steps for grid 9
  !	first zero ff in grid 9
  ig = ng9
  do ir = 1,nr9
     do it = 1,nt
        do iu = 1,nu
           ff(iu,it,ir,ig) = zero
        enddo
        fn(it,ir,ig) = zero
     enddo
  enddo
  igr = 0
  call startgr(igr,ig,kr,lr,lt,dr,dcosth)
  lz = nz9
  dz = dz9
  kz = lz/2+nint(rstar/dz+one)
  do irot0 = 1,nt,mysize
     irot = irot0+myrank
     crot = dcos9*(nt-irot+half)
     rot = acos(crot)
     do ix = ix1,ix2
        !	start with stellar spectrum
        do iu = 1,nu
           fwj(iu,1) = bus(iu)
        enddo
        do iz = kz,lz
           call stepd(fwj,ix,iy,iz,ig)
        enddo
     enddo  !  ix
  enddo  !  irot

  !	add starlight to dust spectra and compare outgoing to stellar
  ffstar = zero
  fnstar = zero
  starsum = zero
  xtrot = real(nnt)/real(nrot)
  ntrot = nint(xtrot)
  do irot = 1,nrot
     it1 = nt-xtrot*(nrot-irot+one)+one+half
     it2 = nt-xtrot*(nrot-irot)+half
     starf = zero
     if(it1.ge.1) then
        do it = it1,it2
           !	now include u < ud(1) by modifying dud(1)
           do iu = 1,nu
              fw(iu,1,irot) = fw(iu,1,irot)+fw(iu,2,it)/xtrot
              starf = starf+fw(iu,2,it)*dud(iu)/xtrot
           enddo
        enddo
     else
        do iu = 1,nu
           fw(iu,1,irot) = fw(iu,1,irot)+astar*bus(iu)
           starf = starf+astar*bus(iu)*dud(iu)
        enddo
     endif
     sumfw = fw(1,1,irot)*ud(1)/four
     do iu = 1,nu
        sumfw = sumfw+fw(iu,1,irot)*dud(iu)
     enddo
     ffstar = ffstar+sumfw
     starsum = starsum+starf
     fnstar = fnstar+one
  enddo
  ffstar = ffstar/(fnstar*sumfs)
  starsum = starsum/(fnstar*sumfs)
  hcsum = hcsum/(xlstar*xlsun)
  xlaccr = gmmdot/(two*rin*xlstar*xlsun)
  if(doprint) then
     print '(" outgoing flux/stellar:",f10.3)', ffstar
     print '(" just starlight:",f10.3)', starsum
     print '(" viscous heating, net gas heating power/stellar:", &
          1p,2e10.2)', xlaccr,hcsum
  endif
  if(doplot) then
     write(16,'(" outgoing flux/stellar:",f10.3)') ffstar
     write(16,'(" just starlight:",f10.3)') starsum
  endif
  ffstar = (ffstar-starsum)/(one+hcsum-starsum)
  if((nit.lt.4).or.(nit.eq.lit-1)) then
     ffstar = one
  else
     ffstar = min(1.7,max(0.6,ffstar))
  endif
  if(doprint) print '(" correction factor:",f10.3)', one/ffstar

  if(doplot) then
     !	plot SEDs including starlight
     print '(" plotting SEDs including starlight")'
     fwmn = fw(1,1,1)*dud(2)/fwmx
     do ipl = 1,8
        irot = (ipl*nrot)/8
        spec(1,ipl) = slog10(fwmn)
        do iu = 2,nu
           fwnorm = fw(iu,1,irot)*dud(iu)/fwmx
           spec(iu,ipl) = slog10(max(fwmn,fwnorm))
        enddo
     enddo
     if(lastit) then
        open(unit=10,file='seds.mon',access='sequential')
        do iu = 1,nu
           write(10,'(i6,8f9.5)') iu,(spec(iu,ipl),ipl=1,8)
        enddo
        close(unit=10)
        monfile = 'seds.spec'
     endif
     call plotspec(spec,mw,nu,8,1,0.,monfile)
     call waitasec(wait,2)
     do ipl = 1,8
        irot = (ipl*nrot)/8
        xn13 =-slog10((ud(36)*fw(36,1,irot))/(ud(30)*fw(30,1,irot))) &
             /slog10(ud(36)/ud(30))
        xn25 =-slog10((ud(30)*fw(30,1,irot))/(ud(26)*fw(26,1,irot))) &
             /slog10(ud(30)/ud(26))
        xn31 =-slog10((ud(30)*fw(30,1,irot))/(ud(24)*fw(24,1,irot))) &
             /slog10(ud(30)/ud(24))
        !            print '(" SED indices:",3f8.3)', xn13,xn25,xn31
        if(lastit) write(16,'(" SED indices:",3f8.3)') xn13,xn25,xn31
     enddo
  endif

  !	sum starlight mean intensities
  if(ifmpi) then
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           call mpi_allreduce(MPI_IN_PLACE,fn(1,ir,ig),nt, &
                MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
           call mpi_allreduce(MPI_IN_PLACE,ff(1,1,ir,ig),mu*nt, &
                MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
        enddo
     enddo
  endif
  !	add starlight to disklight mean intensities
  nzero = 0
  sumfn = zero
  sumn = zero
  fnmin = one
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        if(r.lt.rstar) then
           ostar = one
        elseif(r.lt.(hun*rstar)) then
           ostar = (one-sqrt(one-(rstar/r)**2))/two
        else
           ostar = quart*(rstar/r)**2
        endif
        do it = 1,nt
           if(smooth.and.(igr.eq.0)) then
              !	3 point angular average in grid 9
              !	is this a good idea?
              jt1 = it-1
              jt2 = it+1
              fni = zero
              do jt = jt1,jt2
                 if(jt.lt.1) then
                    kt = 1
                 elseif(jt.gt.nt) then
                    kt = 2*nt-jt+1
                 else
                    kt = jt
                 endif
                 fni = fni+fn(kt,ir,ig)
              enddo
           else
              fni = fn(it,ir,ig)
           endif
           if(fni.gt.fnmin) then
              sumfn = sumfn+fni
              sumn = sumn+one
              wtf = ostar/fni
              if(smooth.and.(igr.eq.0)) then
                 !	put ffstar correction into gg before adding starlight
                 do iu = 1,nu
                    gg(iu,it,ir,ig) = gg(iu,it,ir,ig)/ffstar
                 enddo
                 !	3 point angular smooth of ff in grid 9
                 jt1 = it-1
                 jt2 = it+1
                 do jt = jt1,jt2
                    if(jt.lt.1) then
                       kt = 1
                    elseif(jt.gt.nt) then
                       kt = 2*nt-jt+1
                    else
                       kt = jt
                    endif
                    do iu = 1,nu
                       gg(iu,it,ir,ig) = gg(iu,it,ir,ig) &
                            +wtf*ff(iu,kt,ir,ig)
                    enddo
                 enddo
              else
                 !	put ffstar correction into gg while adding starlight
                 do iu = 1,nu
                    gg(iu,it,ir,ig) = gg(iu,it,ir,ig)/ffstar &
                         +wtf*ff(iu,it,ir,ig)
                 enddo
              endif
           else
              !	leave out ff if no starlt rays pass through?  could I use ff(ir+1)?
              do iu = 1,nu
                 gg(iu,it,ir,ig) = gg(iu,it,ir,ig)/ffstar
              enddo
              if((it.le.lt).and.(r.gt.rin)) nzero = nzero+1
           endif
        enddo  !  it
        do it = 1,nt
           if(nit.eq.(lit-1)) gguv(it,ir,ig) = gg(iufl,it,ir,ig)
           if((fn(it,ir,ig).gt.zero).and.(r.gt.two*rstar)) then
              do iu = 1,nu
                 ff(iu,it,ir,ig) = ostar*ff(iu,it,ir,ig)/fn(it,ir,ig)
              enddo
           else
              do iu = 1,nu
                 ff(iu,it,ir,ig) = zero
              enddo
           endif
        enddo
     enddo  !  ir
  enddo  !  igr
  if(doprint) &
       print '(" for starlight, mean rays/cell, zeros:",f8.2,i8)', &
       sumfn/sumn,nzero

  !	plot mean intensity / stellar on xy grid
  call copyarrr(gg,mu,nu)
  if(doplot) then
     if(rim.lt.rgrid1) then
        !            print '(" plotting starlight / unattentuated")'
        !            call plotggfs(ff,ng9,iupl)
        !            call waitasec(wait,2)
        print '(" plotting disk light + starlight / stellar")'
        call plotggfs(gg,ng9,iupl)
        call waitasec(wait,2)
     endif
     print '(" plotting disk light + starlight / stellar")'
     call plotggfs(gg,igpl,iupl)
     call waitasec(wait,2)
  endif

  if(doprint) &
       print '(" calculate gas and dust temperatures")'
  !	first calculate temperatures in grid 9
  igr = 0
  call startgr(igr,ig,kr,lr,lt,dr,dcosth)
  !	loop over angles, farming out
  dtsum = zero
  dnsum = zero
  dtmax = zero
  hcsum = zero
  igdtmx = 0
  irdtmx = 0
  itdtmx = 0
  do it0 = 1,nt,mysize
     it = it0+myrank
     colin = zero
     taucont = zero
     do ir = kr,lr
        r = dr*(ir-half)
        dens = dg(it,ir,ig)
        !	remove exponential decay and inner rolloff from sigma for visc heating
        sigma = two*colz(nt,ir,ig)/(one+(r0/r)**(qcol+pcol))
        if(r1.gt.zero) sigma = sigma*sexp(r/r1)
        sigma = max(sigma,1.0d+18)
        tgi = tg(it,ir,ig)
        tdi = td(it,ir,ig)
        pres = dens*tgi
        tsubli = tsubl*max(one,pres)**gsubl
        colup = colz(it,ir,ig)
        xwat = xwat0*sexp(-(tfrwat/tdi)**10)
        xco = xco0*sexp(-(tfrco/tdi)**10)
        !	enhance CO where carbon is burned
        if((xburn.gt.one).and.(tburn.gt.one)) &
             xco = xco*(xburn+(one-xburn)*sexp(-(tgi/tburn)**10))
        if(taucont.le.zero) then
           xwat = xwat/hun
           xco = xco/hun
        endif
        !	gastemp calculates temperatures of grain species and gas
        !	from equations of heating and cooling
        call gastemp(it,ir,ig,iamax,tsubli,tgi,tdi,hcgas,lastit)
        dti = tgi-tg(it,ir,ig)
        dtsum = dtsum+dti**2
        dnsum = dnsum+one
        if(abs(dti).gt.abs(dtmax)) then
           dtmax = dti
           igdtmx = ig
           irdtmx = ir
           itdtmx = it
        endif
        dens = pres/tgi
        hcsum = hcsum+hcgas*dens*fpi*r**2*dr*dcosth
        !	burn carbon grains; takes effect after next iteration, then permanent
        if(tgi.gt.tburn) then
           do ia = 1,nac
              condens(ia,it,ir,ig) = zero
           enddo
        endif
        tg(it,ir,ig) = tgi
        td(it,ir,ig) = tdi
        dt(it,ir,ig) = dti
        dm(it,ir,ig) = tdi/tsubli
        if(pres.lt.one) dm(it,ir,ig) = one
        colin = colin+opl(ml,it,ir,ig)*dens*dr
        colr(it,ir,ig) = colin
        if(lastit) then
           taucont = tauv(it,ir,ig)
        else
           taucont = taucont+(opa(iuv,it,ir,ig)+sca(iuv,it,ir,ig))*dr
           tauv(it,ir,ig) = taucont
        endif
     enddo  !  ir
     !	broadcast after doing ir loop
     if(ifmpi) then
        do ir = kr,lr
           call mpi_allgather( &
                tg(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                tg(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                td(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                td(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                dt(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                dt(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                dm(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                dm(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                colr(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                colr(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                tauv(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                tauv(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                opa(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                opa(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                sca(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                sca(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                swd(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                swd(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                opl(1,it,ir,ig),ml,MPI_DOUBLE_PRECISION, &
                opl(1,it0,ir,ig),ml,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           call mpi_allgather( &
                condens(1,it,ir,ig),ma,MPI_DOUBLE_PRECISION, &
                condens(1,it0,ir,ig),ma,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
!!$ TODO: Make cooling arrays inside main program using modular cooling functions
!!$ For now cooling arrays are in outdated common blocks. Do same for heating.
           CALL MPI_ALLGATHER( &
                CoolGasH2ORotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasH2ORotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasH2OVibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasH2OVibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasCORotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasCORotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasCOVibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasCOVibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasH2RotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasH2RotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasH2VibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasH2VibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasCIIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasCIIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasOIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasOIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolGasTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolGasTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)

!!$ STH: communicate abundance arrays

           CALL MPI_ALLGATHER( &
                AbundCIIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AbundCIIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                AbundOIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AbundOIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                AbundeArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AbundeArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                AbundHArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AbundHArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                AbundH2Array(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AbundH2Array(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)

!!$ STH: communicate gastemp arrays

           CALL MPI_ALLGATHER( &
                HeatGasPEArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatGasPEArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                HeatGasXRArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatGasXRArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                HeatGasAccrArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatGasAccrArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                HeatGasTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatGasTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                HeatDustTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatDustTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                HeatTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                HeatTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolDustTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolDustTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                CoolTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                CoolTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)
           CALL MPI_ALLGATHER( &
                AccomArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                AccomArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                MPI_COMM_WORLD,ierr)

        enddo  !  ir
     endif ! if(mpi)
  enddo  !  it0

  !	calculate temperatures in grids 1-8
  !	loop over angles, farming out
  do it0 = 1,nt,mysize
     it = it0+myrank
     costh = dcosth*(nt-it+half)
     lt9 = nt-nn9*(nt-it)
     kt9 = lt9-nn9+1
     colin = zero
     taucont = zero
     do igr = 1,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        if((igr.eq.1).and.(kt9.ge.1).and.(lt9.le.nt)) then
           do ir = kr,lr
              lr9 = ir*nn9
              kr9 = lr9-nn9+1
              sumtg = zero
              sumtd = zero
              sumcolr = zero
              sumtauv = zero
              do it9 = kt9,lt9
                 do ir9 = kr9,lr9
                    sumtg = sumtg+tg(it9,ir9,ng9)
                    sumtd = sumtd+td(it9,ir9,ng9)
                 enddo
                 sumcolr = sumcolr+colr(it9,lr9,ng9)
                 sumtauv = sumtauv+tauv(it9,lr9,ng9)
              enddo
              tg(it,ir,ig) = sumtg/xnn9
              td(it,ir,ig) = sumtd/xnn9
              colin = sumcolr/xn9
              colr(it,ir,ig) = colin
              taucont = sumtauv/xn9
              tauv(it,ir,ig) = taucont
           enddo
        else
           do ir = kr,lr
              r = dr*(ir-half)
              if(r.lt.rin) taucont = zero
              dens = dg(it,ir,ig)
              sigma = two*colz(nt,ir,ig)/(one+(r0/r)**(qcol+pcol))
              if(r1.gt.zero) sigma = sigma*sexp(r/r1)
              sigma = max(sigma,1.0d+18)
              tgi = tg(it,ir,ig)
              tdi = td(it,ir,ig)
              pres = dens*tgi
              tsubli = tsubl*max(one,pres)**gsubl
              colup = colz(it,ir,ig)
              !	what molecular density should I take where dust is evaporated?
              xwat = xwat0*sexp(-(tfrwat/tdi)**10)
              xco = xco0*sexp(-(tfrco/tdi)**10)
              !	enhance CO where carbon is burned
              if((xburn.gt.one).and.(tburn.gt.one)) &
                   xco = xco*(xburn+(one-xburn)*sexp(-(tgi/tburn)**10))
              if(taucont.le.zero) then
                 xwat = xwat/hun
                 xco = xco/hun
              endif
              call gastemp(it,ir,ig,iamax,tsubli,tgi,tdi,hcgas,lastit)
              dti = tgi-tg(it,ir,ig)
              if((ig.ne.1).and.(opa(iuv,it,ir,ig).gt.zero)) then
                 dtsum = dtsum+dti**2
                 dnsum = dnsum+one
                 if(abs(dti).gt.abs(dtmax)) then
                    dtmax = dti
                    igdtmx = ig
                    irdtmx = ir
                    itdtmx = it
                 endif
              endif
              dens = pres/tgi
              hcsum = hcsum+hcgas*dens*fpi*r**2*dr*dcosth
              if(tgi.gt.tburn) then
                 do ia = 1,nac
                    condens(ia,it,ir,ig) = zero
                 enddo
              endif
              tg(it,ir,ig) = tgi
              td(it,ir,ig) = tdi
              dt(it,ir,ig) = dti
              dm(it,ir,ig) = tdi/tsubli
              if(pres.lt.one) dm(it,ir,ig) = one
              colin = colin+opl(ml,it,ir,ig)*dens*dr
              colr(it,ir,ig) = colin
              if(lastit) then
                 taucont = tauv(it,ir,ig)
              else
                 taucont = taucont &
                      +(opa(iuv,it,ir,ig)+sca(iuv,it,ir,ig))*dr
                 tauv(it,ir,ig) = taucont
              endif
           enddo  !  ir
        endif  !  copy from grid 9?
     enddo  !  igr
     if(ifmpi) then
        do igr = 1,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              call mpi_allgather( &
                   tg(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   tg(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   td(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   td(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   dt(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   dt(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   dm(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   dm(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   colr(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   colr(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   tauv(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   tauv(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   opa(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   opa(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   sca(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   sca(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   swd(1,it,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   swd(1,it0,ir,ig),mu,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   opl(1,it,ir,ig),ml,MPI_DOUBLE_PRECISION, &
                   opl(1,it0,ir,ig),ml,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              call mpi_allgather( &
                   condens(1,it,ir,ig),ma,MPI_DOUBLE_PRECISION, &
                   condens(1,it0,ir,ig),ma,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
!!$ TODO: Make cooling arrays inside main program using modular cooling functions
!!$ For now cooling arrays are in outdated common blocks. Do same for heating.
              CALL MPI_ALLGATHER( &
                   CoolGasH2ORotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasH2ORotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasH2OVibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasH2OVibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasCORotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasCORotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasCOVibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasCOVibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasH2RotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasH2RotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasH2VibArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasH2VibArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasCIIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasCIIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasOIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasOIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolGasTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolGasTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              
!!$ STH: communicate abundance arrays
              
              CALL MPI_ALLGATHER( &
                   AbundCIIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AbundCIIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   AbundOIArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AbundOIArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   AbundeArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AbundeArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   AbundHArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AbundHArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   AbundH2Array(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AbundH2Array(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              
!!$ STH: communicate gastemp arrays
              
              CALL MPI_ALLGATHER( &
                   HeatGasPEArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatGasPEArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   HeatGasXRArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatGasXRArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   HeatGasAccrArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatGasAccrArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   HeatGasTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatGasTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   HeatDustTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatDustTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   HeatTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   HeatTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolDustTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolDustTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   CoolTotArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   CoolTotArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              CALL MPI_ALLGATHER( &
                   AccomArray(it,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   AccomArray(it0,ir,ig),1,MPI_DOUBLE_PRECISION, &
                   MPI_COMM_WORLD,ierr)
              
           enddo  !  ir
        enddo  !  igr
     endif  !  mpi
  enddo  !  it
  if(ifmpi) then
     call mpi_allreduce(MPI_IN_PLACE,dtsum,1, &
          MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
     call mpi_allreduce(MPI_IN_PLACE,dnsum,1, &
          MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
     call mpi_allreduce(MPI_IN_PLACE,hcsum,1, &
          MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
  endif

  call copywta(tg,dg)
  call copywta(td,dg)
  call copyarr(dt)
  call copyarr(dm)
  call copytau(colr)
  call copytau(tauv)
  call copyarrr(opa,mu,nu)
  call copyarrr(sca,mu,nu)
  call copyarrr(swd,mu,nu)
  call copyarrr(ff,mu,nu)
  call copyarrr(gg,mu,nu)
  call copyarrr(opl,ml,ml)

  rmsdt = sqrt(dtsum/dnsum)
  if(doprint) then
     print '(" midplane sublimation, photosphere radii:", &
          2f10.4)', rim/au,rphot/au
     print '(" rms, max dT:",1p,2e10.2,3i6)', &
          rmsdt,dtmax,itdtmx,irdtmx,igdtmx
  endif

  if(doplot) then
     !	plot tauv
     print '(" plotting log_10(tauv)")'
     call plotcon(tauv,.true.,monfile)
     call waitasec(wait,2)
!!$ tauv is optical depth from star to that point in 0.5 um, V band
     IF (lastit) THEN
        CALL copyarr(tauv)
        PRINT *, "Writing Tauv.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = tauv, &
             NumEltsD1In = SIZE(tauv, 1), &
             NumEltsD2In = SIZE(tauv, 2), &
             NumEltsD3In = SIZE(tauv, 3), &
             FileNameOut = 'Tauv.out')
     END IF ! lastit
     !	plot temperature
     print '(" plotting log_10(gas temperature)")'
     if(lastit) monfile = 'temp.con'
     call plotcon(tg,.true.,monfile)
     call waitasec(wait,2)
     IF (lastit) THEN
        CALL copyarr(tg)
        PRINT *, "Writing GasTemp.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = tg, &
             NumEltsD1In = SIZE(tg, 1), &
             NumEltsD2In = SIZE(tg, 2), &
             NumEltsD3In = SIZE(tg, 3), &
             FileNameOut = 'GasTemp.out')
!!$ units K
        
!!$ Write out cooling arrays wherever tg is tg is written out. Units in erg s^-1 particle^-1
!!$ TODO: Do same for heating
!!$ TODO: pisco crashes when calling copyarr for my arrays. why?

        !!$ CALL copyarr(CoolGasH20RotArray)
        PRINT *, "Writing CoolGasH2ORot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasH2ORotArray, &
             NumEltsD1In = SIZE(CoolGasH2ORotArray, 1), &
             NumEltsD2In = SIZE(CoolGasH2ORotArray, 2), &
             NumEltsD3In = SIZE(CoolGasH2ORotArray, 3), &
             FileNameOut = 'CoolGasH2ORot.out')
        
        !!$ CALL copyarr(CoolGasH20VibArray)
        PRINT *, "Writing CoolGasH2OVib.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasH2OVibArray, &
             NumEltsD1In = SIZE(CoolGasH2OVibArray, 1), &
             NumEltsD2In = SIZE(CoolGasH2OVibArray, 2), &
             NumEltsD3In = SIZE(CoolGasH2OVibArray, 3), &
             FileNameOut = 'CoolGasH2OVib.out')
        
        !!$ CALL copyarr(CoolGasC0RotArray)
        PRINT *, "Writing CoolGasCORot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasCORotArray, &
             NumEltsD1In = SIZE(CoolGasCORotArray, 1), &
             NumEltsD2In = SIZE(CoolGasCORotArray, 2), &
             NumEltsD3In = SIZE(CoolGasCORotArray, 3), &
             FileNameOut = 'CoolGasCORot.out')
        
        !!$ CALL copyarr(CoolGasC0VibArray)
        PRINT *, "Writing CoolGasCOVib.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasCOVibArray, &
             NumEltsD1In = SIZE(CoolGasCOVibArray, 1), &
             NumEltsD2In = SIZE(CoolGasCOVibArray, 2), &
             NumEltsD3In = SIZE(CoolGasCOVibArray, 3), &
             FileNameOut = 'CoolGasCOVib.out')
        
        !!$ CALL copyarr(CoolGasH2RotArray)
        PRINT *, "Writing CoolGasH2Rot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasH2RotArray, &
             NumEltsD1In = SIZE(CoolGasH2RotArray, 1), &
             NumEltsD2In = SIZE(CoolGasH2RotArray, 2), &
             NumEltsD3In = SIZE(CoolGasH2RotArray, 3), &
             FileNameOut = 'CoolGasH2Rot.out')
        
        !!$ CALL copyarr(CoolGasH2VibArray)
        PRINT *, "Writing CoolGasH2Vib.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasH2VibArray, &
             NumEltsD1In = SIZE(CoolGasH2VibArray, 1), &
             NumEltsD2In = SIZE(CoolGasH2VibArray, 2), &
             NumEltsD3In = SIZE(CoolGasH2VibArray, 3), &
             FileNameOut = 'CoolGasH2Vib.out')
        
        !!$ CALL copyarr(CoolGasCIIArray)
        PRINT *, "Writing CoolGasGasCII.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasCIIArray, &
             NumEltsD1In = SIZE(CoolGasCIIArray, 1), &
             NumEltsD2In = SIZE(CoolGasCIIArray, 2), &
             NumEltsD3In = SIZE(CoolGasCIIArray, 3), &
             FileNameOut = 'CoolGasGasCII.out')

        !!$ CALL copyarr(CoolGasOIArray)
        PRINT *, "Writing CoolGasOI.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasOIArray, &
             NumEltsD1In = SIZE(CoolGasOIArray, 1), &
             NumEltsD2In = SIZE(CoolGasOIArray, 2), &
             NumEltsD3In = SIZE(CoolGasOIArray, 3), &
             FileNameOut = 'CoolGasOI.out')
        
        !!$ CALL copyarr(CoolGasTotArray)
        PRINT *, "Writing CoolGasTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolGasTotArray, &
             NumEltsD1In = SIZE(CoolGasTotArray, 1), &
             NumEltsD2In = SIZE(CoolGasTotArray, 2), &
             NumEltsD3In = SIZE(CoolGasTotArray, 3), &
             FileNameOut = 'CoolGasTot.out')

!!$ STH: Write out abundance arrays

        !!$ CALL copyarr(AbundCIIArray)
        PRINT *, "Writing AbundCII.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AbundCIIArray, &
             NumEltsD1In = SIZE(AbundCIIArray, 1), &
             NumEltsD2In = SIZE(AbundCIIArray, 2), &
             NumEltsD3In = SIZE(AbundCIIArray, 3), &
             FileNameOut = 'AbundCII.out')

        !!$ CALL copyarr(AbundOIArray)
        PRINT *, "Writing AbundOI.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AbundOIArray, &
             NumEltsD1In = SIZE(AbundOIArray, 1), &
             NumEltsD2In = SIZE(AbundOIArray, 2), &
             NumEltsD3In = SIZE(AbundOIArray, 3), &
             FileNameOut = 'AbundOI.out')
        
        !!$ CALL copyarr(AbundeArray)
        PRINT *, "Writing Abunde.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AbundeArray, &
             NumEltsD1In = SIZE(AbundeArray, 1), &
             NumEltsD2In = SIZE(AbundeArray, 2), &
             NumEltsD3In = SIZE(AbundeArray, 3), &
             FileNameOut = 'Abunde.out')
        
        !!$ CALL copyarr(AbundHArray)
        PRINT *, "Writing AbundH.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AbundHArray, &
             NumEltsD1In = SIZE(AbundHArray, 1), &
             NumEltsD2In = SIZE(AbundHArray, 2), &
             NumEltsD3In = SIZE(AbundHArray, 3), &
             FileNameOut = 'AbundH.out')
        
        !!$ CALL copyarr(AbundH2Array)
        PRINT *, "Writing AbundH2.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AbundH2Array, &
             NumEltsD1In = SIZE(AbundH2Array, 1), &
             NumEltsD2In = SIZE(AbundH2Array, 2), &
             NumEltsD3In = SIZE(AbundH2Array, 3), &
             FileNameOut = 'AbundH2.out')

!!$ STH: Write out radiation field in erg/(s cm^2 sr cm^-1)
!!$ for gg array, lambda = 10^3 10^(-4n/64) in microns for n = 1,2,...64
        CALL copyarr(gg)
        
        PRINT *, "Writing MeanIntensJw01um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(64, :, :, :), &
             NumEltsD1In = SIZE(gg(64, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(64, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(64, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw01um.out')

        PRINT *, "Writing MeanIntensJw03um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(56, :, :, :), &
             NumEltsD1In = SIZE(gg(56, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(56, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(56, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw03um.out')

        PRINT *, "Writing MeanIntensJw1um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(48, :, :, :), &
             NumEltsD1In = SIZE(gg(48, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(48, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(48, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw1um.out')

        PRINT *, "Writing MeanIntensJw3um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(40, :, :, :), &
             NumEltsD1In = SIZE(gg(40, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(40, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(40, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw3um.out')

        PRINT *, "Writing MeanIntensJw10um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(32, :, :, :), &
             NumEltsD1In = SIZE(gg(32, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(32, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(32, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw10um.out')

        PRINT *, "Writing MeanIntensJw31um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(24, :, :, :), &
             NumEltsD1In = SIZE(gg(24, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(24, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(24, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw31um.out')

        PRINT *, "Writing MeanIntensJw100um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(16, :, :, :), &
             NumEltsD1In = SIZE(gg(16, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(16, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(16, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw100um.out')

        PRINT *, "Writing MeanIntensJw316um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(8, :, :, :), &
             NumEltsD1In = SIZE(gg(8, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(8, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(8, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw316um.out')

        PRINT *, "Writing MeanIntensJw866um.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = gg(1, :, :, :), &
             NumEltsD1In = SIZE(gg(1, :, :, :), 1), &
             NumEltsD2In = SIZE(gg(1, :, :, :), 2), &
             NumEltsD3In = SIZE(gg(1, :, :, :), 3), &
             FileNameOut = 'MeanIntensJw866um.out')

!!$ STH: Write out line of sight to star column density
!!$      Ntostar defined as colg from Lacy (see comment for "colg =" below)

        CALL copyarr(colr)
        CALL copyarr(colz)
        NtostarArray = 1./(1./colr(:, :, :) + 1./colz(:, :, :))
        !!$ CALL copyarr(NtostarArray)
        PRINT *, "Writing Ntostar.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = NtostarArray, &
             NumEltsD1In = SIZE(NtostarArray, 1), &
             NumEltsD2In = SIZE(NtostarArray, 2), &
             NumEltsD3In = SIZE(NtostarArray, 3), &
             FileNameOut = 'Ntostar.out')
        
!!$ STH: Write out heating arrays

        !!$ CALL copyarr(HeatGasPEArray)
        PRINT *, "Writing HeatGasPE.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatGasPEArray, &
             NumEltsD1In = SIZE(HeatGasPEArray, 1), &
             NumEltsD2In = SIZE(HeatGasPEArray, 2), &
             NumEltsD3In = SIZE(HeatGasPEArray, 3), &
             FileNameOut = 'HeatGasPE.out')

        !!$ CALL copyarr(HeatGasXRArray)
        PRINT *, "Writing HeatGasXR.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatGasXRArray, &
             NumEltsD1In = SIZE(HeatGasXRArray, 1), &
             NumEltsD2In = SIZE(HeatGasXRArray, 2), &
             NumEltsD3In = SIZE(HeatGasXRArray, 3), &
             FileNameOut = 'HeatGasXR.out')     

        !!$ CALL copyarr(HeatGasAccrArray)
        PRINT *, "Writing HeatGasAccr.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatGasAccrArray, &
             NumEltsD1In = SIZE(HeatGasAccrArray, 1), &
             NumEltsD2In = SIZE(HeatGasAccrArray, 2), &
             NumEltsD3In = SIZE(HeatGasAccrArray, 3), &
             FileNameOut = 'HeatGasAccr.out')

        !!$ CALL copyarr(HeatGasTotArray)
        PRINT *, "Writing HeatGasTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatGasTotArray, &
             NumEltsD1In = SIZE(HeatGasTotArray, 1), &
             NumEltsD2In = SIZE(HeatGasTotArray, 2), &
             NumEltsD3In = SIZE(HeatGasTotArray, 3), &
             FileNameOut = 'HeatGasTot.out')

        !!$ CALL copyarr(HeatDustTotArray)
        PRINT *, "Writing HeatDustTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatDustTotArray, &
             NumEltsD1In = SIZE(HeatDustTotArray, 1), &
             NumEltsD2In = SIZE(HeatDustTotArray, 2), &
             NumEltsD3In = SIZE(HeatDustTotArray, 3), &
             FileNameOut = 'HeatDustTot.out')

        !!$ CALL copyarr(HeatTotArray)
        PRINT *, "Writing HeatTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = HeatTotArray, &
             NumEltsD1In = SIZE(HeatTotArray, 1), &
             NumEltsD2In = SIZE(HeatTotArray, 2), &
             NumEltsD3In = SIZE(HeatTotArray, 3), &
             FileNameOut = 'HeatTot.out')

        !!$ CALL copyarr(CoolDustTotArray)
        PRINT *, "Writing CoolDustTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolDustTotArray, &
             NumEltsD1In = SIZE(CoolDustTotArray, 1), &
             NumEltsD2In = SIZE(CoolDustTotArray, 2), &
             NumEltsD3In = SIZE(CoolDustTotArray, 3), &
             FileNameOut = 'CoolDustTot.out')

        !!$ CALL copyarr(CoolTotArray)
        PRINT *, "Writing CoolTot.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = CoolTotArray, &
             NumEltsD1In = SIZE(CoolTotArray, 1), &
             NumEltsD2In = SIZE(CoolTotArray, 2), &
             NumEltsD3In = SIZE(CoolTotArray, 3), &
             FileNameOut = 'CoolTot.out')

        !!$ CALL copyarr(AccomArray)
        PRINT *, "Writing GasDustAccomCoeff.out"
        CALL Write3DArrayAs2DArray( &
             Array3DIn = AccomArray, &
             NumEltsD1In = SIZE(AccomArray, 1), &
             NumEltsD2In = SIZE(AccomArray, 2), &
             NumEltsD3In = SIZE(AccomArray, 3), &
             FileNameOut = 'GasDustAccomCoeff.out')

     END IF ! if(lastit)
     
     !	plot dust temperature / sublimation
     !          print '(" plotting dust temperature / sublimation")'
     !          call plotcon(dm,.false.,monfile)
     !          call waitasec(wait,2)
     !	plot delta temperature
     !          print '(" plotting temperature change")'
     !          call plotcon(dt,.false.,monfile)
     !          call waitasec(wait,2)
     !	make plot of density and temperature
     do igr = 1,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           r = dr*(ir-half)
           iw = ir+(ig-1)*nr/2
           if((ig.le.ng).and.(iw.gt.0).and.(iw.le.mw)) then
              if(r.lt.rstar) r = rstar
              dens = dg(nt,ir,ig)
              colup = colz(nt,ir,ig)*xmg
              tgi = tg(nt,ir,ig)
              tdi = td(nt,ir,ig)
              tsubli = tsubl*max(one,dens*tgi)**gsubl
              do it = 1,nt
                 if(tauv(it,ir,ig).lt.one) itrim = it
              enddo
              tgrim = tg(itrim,ir,ig)
              tdrim = td(itrim,ir,ig)
              smin = 1.0d-02
              smax = 1.0d+06
              spec(iw,1) = slog10(max(smin,min(smax,colup)))
              spec(iw,2) = slog10(max(smin,min(smax,tgi)))
              spec(iw,3) = slog10(max(smin,min(smax,tdi)))
              spec(iw,4) = slog10(max(smin,min(smax,tgrim)))
              spec(iw,5) = slog10(max(smin,min(smax,tdrim)))
              spec(iw,6) = spec(iw,16)
           endif
        enddo  !  ir
     enddo  !  igr
     nwspec = min(mw,iw)
     monfile = ''
     if(lastit) monfile = 'midplane'
     print '(" plotting log(Ng, mid Tg, Td, surf Tg, Td, T_C&G)")'
     print '("             ___   _ _   _._.   ....   ___   _ _")'
     call plotspec(spec,mw,nwspec,6,1,zero,monfile)
     call sleep(4)
  endif
  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)

  !	loop back to hydro equil calculation
  !	if I check rmsdt I need to do the modified lastit
  if(nit.lt.lit) goto 200
!!$ STH: END ITERATIVE CALCULATIONS OF DISK STRUCTURE
!!$ TODO: Modularize dust radiative transfer and remove goto statements

  !	save results of dust calculation
  if(doprint) then
     call savemodel
  endif

  !	start radiative transfer in molecular lines
  !	start here if reusing dust disk model

300 if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)
  moltype = abs(moltype)
  if(moltype.eq.0) then
     if(ifmpi) call mpi_finalize(ierr)
     stop
  endif

  !	calculate colin and tauv.  probably not needed unless reuse = true
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        do it = nt,1,-1
           if(ir.gt.kr) then
              colr(it,ir,ig) = colr(it,ir-1,ig) &
                   +opl(ml,it,ir-1,ig)*dg(it,ir-1,ig)*dr
              tauv(it,ir,ig) = tauv(it,ir-1,ig) &
                   +opa(iuv,it,ir-1,ig)*dr
           elseif(igr.gt.1) then
              colr(it,ir,ig) = colr(it,lr,ig-1) &
                   +opl(ml,it,lr,ig-1)*dg(it,lr,ig-1)*dr/two
              tauv(it,ir,ig) = tauv(it,lr,ig-1) &
                   +opa(iuv,it,lr,ig-1)*dr/two
           else
              colr(it,ir,ig) = zero
              tauv(it,ir,ig) = zero
           endif
        enddo
     enddo
  enddo
  call copytau(colr)
  call copytau(tauv)

  !	set up velocity arrays
  !	could add turbulence and radial pressure gradient influence
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     if(igr.le.1) itwind = nt
     do ir = kr,lr
        r = dr*(ir-half)
        if(wmdot*vwind.ne.zero) then
           dgw = 1.001d+00*wmdot/(vwind*r**2)
        else
           dgw = zero
        endif
        inwind = .false.
        do it = nt,1,-1
           costh = dcosth*(nt-it+half)
           if((it.le.itwind).and.(dg(it,ir,ig).lt.dgw)) then
              inwind = .true.
              itwind = it
           endif
           !	wr and wth may be hardwired = 0
           if(r.lt.rstar) then
              wr(it,ir,ig) = zero
              wth(it,ir,ig) = zero
              wph(it,ir,ig) = vorb*sqrt(au/rstar)*sqrt(one-costh**2)
           elseif(inwind) then
              wr(it,ir,ig) = vwind
              wth(it,ir,ig) = zero
              wph(it,ir,ig) = zero
           else
              wr(it,ir,ig) = vterm*sqrt(one-rstar/r)
              wth(it,ir,ig) = zero
              wph(it,ir,ig) = vorb*sqrt(au/r)*sqrt(one-costh**2)
           endif
        enddo  !  it
     enddo  !  ir
  enddo  !  igr
  call copyarr(wr)
  call copyarr(wth)
  call copyarr(wph)

  nx = lx
  nrot = lrot
  dcrot = one/nrot
  ny = nx
  if(bipolar) then
     ly = lx/2
  else
     ly = lx
  endif
  nx2 = nx/2
  ny2 = ny/2
  nz2 = nz/2
  nx9 = nn9*nx
  !	keep nz from dust model
  nz9 = nn9*nz
  xnx = nx
  xnz = nz
  dx0 = (two*nr*dr0)/xnx
  dx9 = two*dx0/xn9
  dz0 = xnx*dx0/xnz
  dz9 = two*dz0/xn9
  ll = nl
  lw = nw

!!$ STH: Original J lines calculations; jfirst > jlast
!!$line   !	first J,K
!!$line   jfirst = 30./sqrt(be)
!!$line   if(moltype.eq.5) jfirst = 2*(jfirst/2)+1
!!$line   jlast = 1

!!$ STH: For quick estimate of spectrum, run pisco with
!!$ reuse = .FALSE.; jfirst = 15, jlast = 5
  jfirst = 15
  jlast = 5
  
  ju = jfirst
  if(moltype.eq.3) then
     kk = ju
  else
     kk = 0
  endif
  !	start here after first J if want to start with diffusion approx
310 jp = ju+1
  jq = ju
  jr = ju-1
  call initju(ju,kk)
  gjp = gnucl*(two*xjp+one)
  gjq = gnucl*(two*xjq+one)
  gjr = gnucl*(two*xjr+one)
  ejp = xjp*(xjp+one)
  ejq = xjq*(xjq+one)
  ejr = xjr*(xjr+one)
  do il = 1,nl1
     wi = wl(il)
     !	assume a flat spectrum near each line
     fstar(il) = bw(wi,tstar)
  enddo
  do iw = 1,mw*ml
     do jpl = 1,mpl
        fwq(iw,jpl) = zero
     enddo
  enddo

  !	calculate molecular density and populations
  !	don''t bother to farm out
  !	dens and gctg don''t depend on J, but gnucl might, so leave here
  rphoto = zero
  rhi = zero
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     !	calculate LTE level populations
     do ir = kr,lr
        !	option to let molecules survive inside of sublimation front
        jr = 1.1*ir
        if(jr.le.lr) then
           jg = ig
        elseif(igr.eq.0) then
           jg = 2
           jr = jr/(2*nn9)
        else
           jg = ig+1
           jr = jr/2
        endif
        r = dr*(ir-half)
        tdmid = max(ten,td(nt,ir,ig))
        do it = nt,1,-1
           if((igr.eq.0).and.(jg.eq.2)) then
              jt = nt-(nt-it)/nn9
           else
              jt = it
           endif
           tgi = max(ten,tg(it,ir,ig))
           tdi = max(ten,td(it,ir,ig))
           dens = dg(it,ir,ig)
           colin = colr(it,ir,ig)
           if(reuse) then
              !	use Doty calculated molecular abundance
              dmol = xmol*dens*dl(8,it,ir,ig)
              !	assume molecules are destroyed by UV inside coldiss
              !	and by heat above tdiss
           elseif(((colin.lt.coldiss).and.(tauv(it,ir,ig).lt.fifth)) &
                .or.(tgi.gt.tdiss)) then
              dmol = zero
              if(it.eq.nt) rphoto = r
              !	assume molecules can''t form without dust
           elseif(tauv(it,ir,ig).eq.zero) then
              !	let SiO extend inward from sublimation front
              !              elseif(tauv(jt,jr,jg).eq.zero) then
              dmol = zero
           else
              if(tfrmol.gt.zero) then
                 dmol = dens*xmol*sexp(-(tfrmol/tdi)**10)
              elseif(tfrmol.lt.zero) then
                 dmol = dens*xmol*sexp(-(-tfrmol/tdmid)**10)
              else
                 dmol = dens*xmol
              endif
              !	enhance CO where carbon is burned
              if((moltype.eq.1).and.(xburn.gt.one).and.(tburn.gt.one)) &
                   dmol = dmol*(xburn+(one-xburn)*sexp(-(tgi/tburn)**10))
           endif
           !	put optical depth decrease factor into dmol
           dmol = opl(ml,it,ir,ig)*dmol
           if((ig.eq.ng).and.(ir.eq.nr)) dmol = zero
           if(dmol.lt.small) dmol = zero
           dm(it,ir,ig) = dmol
           bkt = bk*tgi
           hcbkt = hcb/bkt
           qrot = bkt/hcb
           !	ignore qvib?
           !	modify qrot for symmetric tops
           if(hcc.gt.zero) then
              qrot = (4./3.)*qrot*sqrt(bkt/hcc)
              ekkt = (hcc-hcb)*xk*xk/bkt
           else
              ekkt = zero
           endif
           dl(1,it,ir,ig) = dmol*gjp*sexp(-ejp*hcbkt-ekkt)/qrot
           dl(2,it,ir,ig) = dmol*gjq*sexp(-ejq*hcbkt-ekkt)/qrot
           dl(3,it,ir,ig) = dmol*gjr*sexp(-ejr*hcbkt-ekkt)/qrot
           if(jr.lt.0) dl(3,it,ir,ig) = zero
           dlte = dl(2,it,ir,ig)*sexp(-hcwe/bkt)
           if(badnum(dlte)) then
              print '(3i6," dlte =",1p,4e10.2)', &
                   it,ir,ig,dlte,dens,dmol,qrot
              if(ifmpi) call mpi_abort(MPI_COMM_WORLD,icode,ierr)
              stop
           endif
           if(dlte.lt.zilch) dlte = zero
           dl(4,it,ir,ig) = dlte
           dl(5,it,ir,ig) = dlte
           dl(6,it,ir,ig) = zero
           dl(7,it,ir,ig) = dlte
           !	is it OK to overwrite chemfile xmol in dl(8)?
           dl(8,it,ir,ig) = popiso*dlte
           gctgi = gcoll*tgi*sexp(-(tcoll/tgi)**third)
           !	increase collision rate where H is atomic
           !	shouldn''t this be consistent with dmol formula?
           !	should increase more where H is ionized
           if(colin.le.colhi) then
              gctgi = 100.*gctgi
              if(it.eq.nt) rhi = r
           elseif(colhi.gt.zero) then
              gctgi = (1.+99.*sexp((colhi-colin)/colhi))*gctgi
           endif
           gctg(it,ir,ig) = gctgi
           rufl(it,ir,ig) = zero
        enddo  !  it
     enddo  !  ir
  enddo  !  igr
  call copyarr(dm)
  call copyarr(gctg)
  call copyarr(rufl)
  call copyarrr(dl,ml,8)
  call copyarrr(sl,ml,nl1)
  call copyarrr(opl,ml,nl1)

  if(doprint) then
     print  &
          '(" midplane dissociation radius for H2 and CO:",2f10.3)', &
          rhi/au,rphoto/au
  endif
  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)

  if(lte) goto 350
  if(doprint) print &
       '(/" Starting diffusion calculation for Ju =",i3)', ju

  !	radial diffusion calculation in expanded grid 1 for inner rim
  !	don''t bother to farm out?
  lw = 1
  !	use il=2 (Q branch) for diffusion
  il = 2
  ll = 2
  ig = ng9
  dr = dr9
  do it = 1,nt
     costh = dcos9*(nt-it+half)
     taucont = zero
     tauline = zero
     tauterm = zero
     do ir = 1,nr9
        r = dr*(ir-half)
        if((ir.eq.1).or.(r.le.rstar)) then
           gg(il,it,ir,ig) = fstar(il)
           fwj(1,il) = fstar(il)
           fwj(2,il) = fstar(il)
        elseif(abs(costh).gt.coswind) then
           ostar = (one-sqrt(one-(rstar/r)**2))/2.
           gg(il,it,ir,ig) = fstar(il)*ostar
        else
           call diffr(fwj,it,ir,ig)
        endif
     enddo
  enddo
  call copyarrr(gg,mu,2)

  !	run radiative transfer with rot = 0 for axial diffusion calculation
  nit = 0
  irot = 0
  rot = zero
  il = 2
  call zerof(2)
  call grid0(fwj,ny/2)
  call copyarrr(ff,mu,2)

  !	take smaller of radial (gg(2)) and axial (ff(2)) diffusion calculations
  !	and copy gg(2) onto gg(il)
  ig = ng9
  do it = 1,nt
     gglast = gg(2,it,1,ig)
     do ir = 1,nr9
        if(fn(it,ir,ig).gt.zero) then
           gglast = ff(2,it,ir,ig)/fn(it,ir,ig)
        endif
        ggthis = min(gg(2,it,ir,ig),gglast)
        do il = 1,nl1
           gg(il,it,ir,ig) = ggthis
        enddo
     enddo
  enddo
  do it = 1,nt
     gglast = gg(2,it,1,1)
     do ig = 1,ng
        kr = nr2+1
        lr = nr
        do ir = kr,lr
           if(fn(it,ir,ig).gt.zero) then
              gglast = ff(2,it,ir,ig)/fn(it,ir,ig)
           endif
           do il = 1,nl1
              gg(il,it,ir,ig) = gglast
           enddo
        enddo
     enddo
  enddo
  call copyarrr(gg,mu,nl1)

  !	done with diffusion calculation
  !	will use gg in popju to calculate level populations
  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)

  ll = nl
  lw = nw

!!$ STH: FOR A GIVEN LINE, BEGIN INITIAL POPULATION LEVELS
  !	start here for Ju after the first if starting with last J solution
350 continue
  nit = 1

  if(doprint) print '(/" Starting iteration for Ju,K =",2i3)', ju,kk
  jp = ju+1
  jq = ju
  jr = ju-1
  !	(re)initialize variables dependent on ju
  call initju(ju,kk)
  gjp = gnucl*(two*xjp+one)
  gjq = gnucl*(two*xjq+one)
  gjr = gnucl*(two*xjr+one)
  ejp = xjp*(xjp+one)
  ejq = xjq*(xjq+one)
  ejr = xjr*(xjr+one)
  do il = 1,nl1
     wi = wl(il)
     !	assume a flat spectrum near each line
     !	probably should interpolate from bus
     fstar(il) = bw(wi,tstar)
  enddo

  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = 1,lr
        do it = 1,lt
           tgi = max(ten,tg(it,ir,ig))
           bkt = bk*tgi
           hcbkt = hcb/bkt
           qrot = bkt/hcb
           !	ignore qvib?
           !	modify qrot for symmetric tops
           if(hcc.gt.zero) then
              qrot = (4./3.)*qrot*sqrt(bkt/hcc)
              ekkt = (hcc-hcb)*xk*xk/bkt
           else
              ekkt = zero
           endif
           dmol = dm(it,ir,ig)
           dl(1,it,ir,ig) = dmol*gjp*sexp(-ejp*hcbkt-ekkt)/qrot
           dl(2,it,ir,ig) = dmol*gjq*sexp(-ejq*hcbkt-ekkt)/qrot
           dl(3,it,ir,ig) = dmol*gjr*sexp(-ejr*hcbkt-ekkt)/qrot
           if(jr.lt.0) dl(3,it,ir,ig) = zero
           dlte = dl(2,it,ir,ig)*sexp(-hcwe/bkt)
           if(badnum(dlte)) then
              print '(3i6," dlte =",1p,e10.2)', it,ir,ig,dlte
              if(ifmpi) call mpi_abort(MPI_COMM_WORLD,icode,ierr)
              stop
           endif
           if(dlte.lt.zilch) dlte = zero
           dl(4,it,ir,ig) = dlte
           dl(5,it,ir,ig) = dlte
           dl(6,it,ir,ig) = zero
           dl(7,it,ir,ig) = dlte
           dl(8,it,ir,ig) = popiso*dlte
        enddo  !  it
     enddo  !  ir
  enddo  !  igr
  call copyarrr(dl,ml,8)

  if(.not.lte) then
     !	call popju to recalculate dl(4-8) using gg
     call popju(rufl,sumdnj)
     call copyarrr(dl,ml,8)
     !	plot departure coefficient
     if(doplot) then
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              do it = 1,nt
                 !	I think it''s safe to reuse dd now
                 if(dl(5,it,ir,ig).gt.tiny) then
                    dd(it,ir,ig) = dl(4,it,ir,ig)/dl(5,it,ir,ig)
                 elseif(dl(4,it,ir,ig).gt.tiny) then
                    dd(it,ir,ig) = dl(4,it,ir,ig)/tiny
                 else
                    dd(it,ir,ig) = one
                 endif
              enddo
           enddo
        enddo
        print '(" plotting log_10(b_ju) on r-theta plot")'
        call plotcon(dd,.true.,'')
        call waitasec(wait,2)
!!$ STH: For line calculations with more than one iteration,
!!$ dont write out initial guess
!!$ TODO: Write out initial guess when there is only one iteration
!!$ Initial guess commented out with !!$init
!!$init        IF (lastit) THEN
!!$init           IF (ju == 10) THEN
!!$init              CALL copyarr(dd)
!!$init              PRINT *, "Writing DepCoeffbju10.out"
!!$init              CALL Write3DArrayAs2DArray( &
!!$init                   Array3DIn = dd, &
!!$init                   NumEltsD1In = SIZE(dd, 1), &
!!$init                   NumEltsD2In = SIZE(dd, 2), &
!!$init                   NumEltsD3In = SIZE(dd, 3), &
!!$init                   FileNameOut = 'DepCoeffbju10.out')
!!$init!!$  dep coeff 0...1
!!$init!!$ Define and write out population ratio for transition with J = 10
!!$init!!$ Follow Lacy's method to avoid NaNs in the output
!!$init        DO igr = 0, ng
!!$init           CALL startgr(igr, ig, kr, lr, lt, dr, dcosth)
!!$init           DO ir = kr, lr
!!$init              DO it = 1, nt
!!$init                 IF (dl(5, it, ir, ig) > tiny) THEN
!!$init                    PopRatioArray(it, ir, ig) = &
!!$init                         dl(4, it, ir, ig) / dl(2, it, ir, ig)
!!$init                 ELSEIF (dl(4,it,ir,ig) > tiny) THEN
!!$init                    PopRatioArray(it, ir, ig) = &
!!$init                         dl(4, it, ir, ig) / tiny
!!$init                 ELSE
!!$init                    PopRatioArray(it, ir, ig) = one
!!$init                 ENDIF ! IF (dl(5, it, ir, ig) > tiny)
!!$init              ENDDO ! DO it = 1, lr
!!$init           ENDDO ! DO ir = kr, lr
!!$init        ENDDO ! ir = 0, ng
!!$init              !!$ CALL copyarr(PopRatioArray)
!!$init              PRINT *, "Writing PopRationjul10.out"
!!$init              CALL Write3DArrayAs2DArray( &
!!$init                   Array3DIn = PopRatioArray, &
!!$init                   NumEltsD1In = SIZE(PopRatioArray, 1), &
!!$init                   NumEltsD2In = SIZE(PopRatioArray, 2), &
!!$init                   NumEltsD3In = SIZE(PopRatioArray, 3), &
!!$init                   FileNameOut = 'PopRationjul10.out')
!!$init!!$ ratio of number densities in upper to lower states for a strong line
!!$init           END IF ! if(ju == 10)
!!$init        END IF ! if(lastit)
     endif ! if(doplot)
     
  else ! if (.not. lte)
     !	plot population ratio
     if(doplot) then
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              do it = 1,nt
                 if(dl(2,it,ir,ig).gt.tiny) then
                    dd(it,ir,ig) = dl(4,it,ir,ig)/dl(2,it,ir,ig)
                 else
                    dd(it,ir,ig) = one
                 endif
              enddo
           enddo
        enddo
        print '(" plotting log_10(n_ju/n_jl) on r-theta plot")'
        call plotcon(dd,.true.,'')
        call waitasec(wait,2)
!!$ TODO: Write out PopRatio (defined as dd here) when doing LTE calculation
     endif
  endif ! if(.not. lte)
!!$ STH: FOR A GIVEN LINE, END INITIAL POPULATION LEVELS

  !	start rad xfer and excitation iteration

  nit = 1
  oldsum = zero
!!$ STH: FOR A GIVEN LINE, BEGIN ITERATIVE POPULATION LEVELS
400 continue

  !	radiative transfer along rays
  if(doprint) print &
       '(/" calculating radiative transfer iteration #",i3)', nit

  call zerog(nl1)

  !	loop over ray directions (grid orientations)
  do irot0 = 1,nrot,mysize
     irot = irot0+myrank
     crot = dcrot*(nrot-irot+half)
     rot = acos(crot)

     call zerof(nl1)

     !	call outer grid routine, which loops over rays and calls inner grids

     call grid0(fwj,ly)

     if(doprint) print &
          '(" grid orientation",i4," of",i4,"  rot =",f8.3)', &
          irot0+mysize/2,nrot,acos(dcrot*(nrot-irot0-mysize/2+half))
     if(doplot) call movie(nc,1)

     !	add contribution to spectrum from +y (with opposite Doppler shifts)
     !	and save and broadcast spectrum
     do il = 1,nl
        do iw = 1,nw
           if(bipolar.and.(iw.le.nw2)) then
              iw1 = nw+1-iw
              fwj(iw,il) = fwj(iw,il)+fwj(iw1,il)
              fwj(iw1,il) = fwj(iw,il)
           endif
           fw(iw,il,irot) = fwj(iw,il)
        enddo
        if(ifmpi) then
           do irank = 0,mysize-1
              call mpi_bcast(fw(1,il,irot0+irank),nw, &
                   MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
           enddo
        endif
     enddo  !  il

     !	add contributions to mean intensity
     if(ifmpi) then
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              call mpi_allreduce(MPI_IN_PLACE,ff(1,1,ir,ig),mu*nt, &
                   MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
              call mpi_allreduce(MPI_IN_PLACE,fn(1,ir,ig),nt, &
                   MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
           enddo
        enddo
     endif
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              gn(it,ir,ig) = gn(it,ir,ig)+fn(it,ir,ig)
              do il = 1,nl1
                 gg(il,it,ir,ig) = gg(il,it,ir,ig)+ff(il,it,ir,ig)
              enddo
           enddo
        enddo
     enddo

     if(doplot) call plotspec(fwj,mw,nw,nl,1,-dv,'')

     !	end loop over grid orientations
  enddo  !  irot

  if(mit.gt.0) then
     !	fill in inner halves so I can smooth radially
     call copyarr(gn)
     call copyarrr(gg,mu,nl1)
     !	divide gg by gn and average if appropriate
     call ggavg(nl1,ntsm,nrsm)

     !	calculate v=1 populations
     if(doprint) print '(" calculating v=1 populations")'
     call popju(rufl,sumdnj)
     call copyarrr(dl,ml,8)

     !	plot departure coefficient
     if(doplot) then
        do igr = 0,ng
           call startgr(igr,ig,kr,lr,lt,dr,dcosth)
           do ir = kr,lr
              do it = 1,nt
                 if(dl(5,it,ir,ig).gt.tiny) then
                    dd(it,ir,ig) = dl(4,it,ir,ig)/dl(5,it,ir,ig)
                 else
                    dd(it,ir,ig) = zero
                 endif
              enddo
           enddo
        enddo
        print '(" plotting log_10(b_ju) on r-theta plots")'
        call plotcon(dd,.true.,'')
        call waitasec(wait,2)
        IF (nit == mit) THEN
           IF (ju == 10) THEN
!!$ Define and write out population ratio for transition with J = 10
!!$ Follow Lacy's method to avoid NaNs in the output
              DO igr = 0, ng
                 CALL startgr(igr, ig, kr, lr, lt, dr, dcosth)
                 DO ir = kr, lr
                    DO it = 1, nt
                       IF (dl(5, it, ir, ig) > tiny) THEN
                          PopRatioArray(it, ir, ig) = &
                               dl(4, it, ir, ig) / dl(2, it, ir, ig)
                       ELSEIF (dl(4,it,ir,ig) > tiny) THEN
                          PopRatioArray(it, ir, ig) = &
                               dl(4, it, ir, ig) / tiny
                       ELSE
                          PopRatioArray(it, ir, ig) = one
                       ENDIF ! IF (dl(5, it, ir, ig) > tiny)
                    ENDDO ! DO it = 1, lr
                 ENDDO ! DO ir = kr, lr
              ENDDO ! ir = 0, ng
!!$ ratio of number densities in upper to lower states for a strong line
              !!$ CALL copyarr(PopRatioArray)
              PRINT *, "Writing PopRationjul10.out"
              CALL Write3DArrayAs2DArray( &
                   Array3DIn = PopRatioArray, &
                   NumEltsD1In = SIZE(PopRatioArray, 1), &
                   NumEltsD2In = SIZE(PopRatioArray, 2), &
                   NumEltsD3In = SIZE(PopRatioArray, 3), &
                   FileNameOut = 'PopRationjul10.out')

              CALL copyarr(dd)
              PRINT *, "Writing DepCoeffbju10.out"
              CALL Write3DArrayAs2DArray( &
                   Array3DIn = dd, &
                   NumEltsD1In = SIZE(dd, 1), &
                   NumEltsD2In = SIZE(dd, 2), &
                   NumEltsD3In = SIZE(dd, 3), &
                   FileNameOut = 'DepCoeffbju10.out')
           END IF ! IF(ju == 10)
        END IF ! IF(nit == mit)
        !	plot mean intensity / dust source function
        !          do igr = 0,ng
        !          call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        !            do ir = kr,lr
        !              do it = 1,nt
        !                if(dl(5,it,ir,ig).gt.tiny) then
        !                  dd(it,ir,ig) = half*(gg(1,it,ir,ig)+gg(3,it,ir,ig)) &
        !                    /bw(wl(2),tg(it,ir,ig))
        !                else
        !                  dd(it,ir,ig) = zero
        !                endif
        !              enddo
        !            enddo
        !          enddo
        !          print '(" plotting log_10(gg/bw(tg)) on r-theta plots")'
        !          call plotcon(dd,.true.,'')
        !          call waitasec(wait,2)
     endif

     !	repeat if nju hasn''t converged

     nit = nit+1
     if((nit.le.mit).and.(sumdnj.gt.1.0d-06)) goto 400
  endif  !  lte only?

  !	store final spectra

!!$ STH: BEGIN PLOTTING PQR BRANCHES
  if(doplot) then
     fwps = fstar(1)*astar
     fwqs = fstar(2)*astar
     fwrs = fstar(3)*astar
     mpl = (npl+7)/8
     w0 = (nw+1)/2.

     print '(" plotting P(",2i2,") spectra")', jp,kk
     write(11,'("P(",2i3,")")') jp,kk
     do jpl = 1,mpl
        lpl = min(npl,8*jpl)
        kpl = max(1,lpl-7)
        do ipl = kpl,lpl
           if(npl.eq.nrot) then
              irot = ipl
           else
              irot = (2*ipl-1)*nrot/(2*npl)
           endif
           call convo(fw(1,1,irot),spec(1,ipl),fwps,dv/vkms,dsm,nsm)
        enddo
        if(spec(1,1).lt.(5.0d+02)) then
           do iw = 1,nw
              vi = -dv*(iw-w0)/vkms
              write(11,'(i4,f8.2,8f8.3)') &
                   iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
           enddo
        else
           do iw = 1,nw
              vi = -dv*(iw-w0)/vkms
              write(11,'(i4,f8.2,8f8.2)') &
                   iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
           enddo
        endif
        call plotspec(spec(1,kpl),mw,nw,8,jpl,-dv/vkms,'')
        call waitasec(wait,2)
     enddo

     if(moltype.gt.1) then
        print '(" plotting Q(",2i2,") spectra")', jq,kk
        write(12,'("Q(",2i3,")")') jq,kk
        do jpl = 1,mpl
           lpl = min(npl,8*jpl)
           kpl = max(1,lpl-7)
           do ipl = kpl,lpl
              irot = (2*ipl-1)*nrot/(2*npl)
              if(npl.eq.nrot) irot = ipl
              call convo(fw(1,2,irot),spec(1,ipl),fwqs,dv/vkms,dsm,nsm)
              do iw = 1,nw
                 iwq = iw-ae*xjq**2/dw
                 if((iwq.ge.1).and.(iwq.le.ml*mw)) &
                      fwq(iwq,ipl) = fwq(iwq,ipl)+spec(iw,ipl)-spec(1,ipl)
              enddo
           enddo
           if(spec(1,1).lt.(5.0d+02)) then
              do iw = 1,nw
                 vi = -dv*(iw-w0)/vkms
                 write(12,'(i4,f8.2,8f8.3)') &
                      iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
              enddo
           else
              do iw = 1,nw
                 vi = -dv*(iw-w0)/vkms
                 write(12,'(i4,f8.2,8f8.2)') &
                      iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
              enddo
           endif
           call plotspec(spec(1,kpl),mw,nw,8,jpl,-dv/vkms,'')
           call waitasec(wait,2)
        enddo
     endif

     print '(" plotting R(",2i2,") spectra")', jr,kk
     write(13,'("R(",2i3,")")') jr,kk
     do jpl = 1,mpl
        lpl = min(npl,8*jpl)
        kpl = max(1,lpl-7)
        do ipl = kpl,lpl
           irot = (2*ipl-1)*nrot/(2*npl)
           if(npl.eq.nrot) irot = ipl
           call convo(fw(1,3,irot),spec(1,ipl),fwrs,dv/vkms,dsm,nsm)
        enddo
        if(spec(1,1).lt.(5.0d+02)) then
           do iw = 1,nw
              vi = -dv*(iw-w0)/vkms
              write(13,'(i4,f8.2,8f8.3)') &
                   iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
           enddo
        else
           do iw = 1,nw
              vi = -dv*(iw-w0)/vkms
              write(13,'(i4,f8.2,8f8.2)') &
                   iw,vi,(spec(iw,ipl),ipl=kpl,lpl)
           enddo
        endif
        call plotspec(spec(1,kpl),mw,nw,8,jpl,-dv/vkms,'')
        call waitasec(wait,2)
     enddo
  endif ! if(doplot)
!!$ STH: END PLOTTING PQR BRANCHES

  !	could do isotopic and hot-band spectra

  if(ifmpi) call mpi_barrier(MPI_COMM_WORLD,ierr)
  if(kk.gt.1) then
     kk = kk-2
     goto 350
  endif

!!$ STH: for more complete spectrum, calculate every few lines
!!$line   if(ju.le.8) then
!!$line      ju = ju-2
!!$line   elseif(ju.le.16) then
!!$line      ju = ju-2
!!$line   elseif(ju.le.32) then
!!$line      ju = ju-4
!!$line   else
!!$line      ju = ju-8
!!$line   endif
!!$line   if(moltype.eq.3) kk = ju

!!$ STH: For rough estimate, calculate every 5th line
  ju = ju - 5

  if(ju.ge.jlast) goto 350
!!$ STH: FOR A GIVEN LINE, END ITERATIVE POPULATION LEVELS

  if(doplot) then
     close(unit=11)
     close(unit=12)
     close(unit=13)
     !          close(unit=14)
     !          close(unit=15)
     open(unit=11,file='spec.q',access='sequential')
     do jpl = 1,mpl
        lpl = min(npl,8*jpl)
        kpl = max(1,lpl-7)
        do iw = 1,ml*nw
           do ipl = kpl,lpl
              fwq(iw,ipl) = fwq(iw,ipl)+spec(1,ipl)
           enddo
           vi = -dv*(iw-w0)/vkms
           write(11,'(i4,f8.2,8f8.3)') &
                iw,vi,(fwq(iw,ipl),ipl=kpl,lpl)
        enddo
        !            call plotspec(fwq(1,kpl),ml*mw,ml*nw,8,jpl,-dv,'')
        !            call waitasec(wait,2)
     enddo
     close(unit=11)
  endif
  if(doprint) close(unit=16)
  if(ifmpi) call mpi_finalize(ierr)

end program pisco



subroutine startgr(igr,ig,kr,lr,lt,dr,dcosth)
  !	initialize dr, etc. for current grid

  implicit real*8 (a-h,o-z)
  parameter (two = 2.0d+00)
  save dr0,dr9,dcost,dcos9
  save nr,nr3,nr9,ng9,nt,nt8

  if((igr.eq.0).or.(igr.eq.ng9)) then
     ig = ng9
     dr = dr9
     kr = 1
     lr = nr9
     dcosth = dcos9
  else
     ig = igr
     dr = dr0*two**ig
     kr = nr3
     lr = nr
     dcosth = dcost
  endif
  if(ig.eq.1) then
     kr = 1
     lt = nt8
  else
     lt = nt
  endif
  return

  entry initgr(xr0,xr9,xcost,xcos9,ir,ir9,ig9,it,it8)

  dr0 = xr0
  dr9 = xr9
  dcost = xcost
  dcos9 = xcos9
  nr = ir
  nr9 = ir9
  ng9 = ig9
  nr3 = nr/2+1
  nt = it
  nt8 = it8
  return

end subroutine startgr



subroutine dustinit(xc,xsi,ac,asi,tuv,xuv,abss,tsubli)

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  dimension spec(mu,ma),emis(mu),opaci(mu)
  logical doprint,badnum
  parameter (pi = 3.14159265d+00)
  parameter (tpi = 6.28318530d+00)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (quart = 0.25d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (ten = 1.0d+01)
  parameter (hun = 1.0d+02)
  parameter (xmg = 4.0d-24)

  nr2 = nr/2
  doprint = (myrank.eq.0)
  !	a = 0.3 nm - 100 um (may be changed)
  !	na = 24; 12 each for carbon and silicates
  la = na/2
  arat = ten**half
  a0 = 1.0d-07
  !	roll off distributions at ac and asi
  !	grain distribution power laws, dn/dlna ~ a^-pow
  powc = 2.5d+00
  pows = 2.0d+00
  !	assume AC grain density = 2 g/cc or 1e23 C atoms/cc
  !	so grain vol/C = 1e-23, or vol/H = 1e-23*XC
  !	solar XC = 3.6e-04, gas particles / H atom = 0.6
  xc = 3.6d-04*xc
  cvolg = (1.0d-23)*xc/(0.6d+00)
  !	assume Sil grain density = 3.6 g/cc, with 172 AMU/Si,
  !	or 1.25e22 Si/cc, or 8e-23 cc/Si
  xsi = 3.5d-05*xsi
  svolg = (8.0d-23)*xsi/(0.6d+00)
  !	u = 11.5 - 10^5 cm-1
  u0 = ten
  dlogu = four/nu
  urat = ten**dlogu
  durat = (urat-one)/sqrt(urat)
  !	w = 328 - 3162 cm-1
  w0 = ten**2.5
  dlogw = one/nu
  wrat = ten**dlogw
  dwrat = (wrat-one)/sqrt(wrat)
  wv = 2.0d+04
  iuv = slog10(wv/u0)/dlogu+half
  wfl = 5.0d+04
  iufl = slog10(wfl/u0)/dlogu+half
  wsil = 1.0d+03
  iusil = slog10(wsil/u0)/dlogu+half
  iwsil = slog10(wsil/w0)/dlogw+half
  if(iwsil.ne.iusil) &
       print '("Warning: iwsil.ne.iusil",2i6)',iwsil,iusil
  sumv = zero
  if(na.ne.24) print '("Warning: na =",i4)', na
  volc = zero
  vols = zero
  a = a0
  do ia = 1,la
     iac = ia
     ias = ia+la
     a = a*arat
     ad(iac) = a
     ad(ias) = a
     !	approximation to Weingartner & Draine (2001)
     !	note: popd = dn/dlna = a*dn/da since a is spaced logarithmically
     pops = one/((a/asi)**pows+(a/asi)**10)
     popc = one/((a/ac)**powc+(a/ac)**10)
     popd(iac) = popc
     popd(ias) = pops
     vola = (4.*pi/3.)*a**3
     volc = volc+popc*vola
     vols = vols+pops*vola
  enddo
  cnorm = cvolg/volc
  snorm = svolg/vols
  do ia = 1,la
     iac = ia
     ias = ia+la
     popd(iac) = cnorm*popd(iac)
     popd(ias) = snorm*popd(ias)
  enddo
  u = u0
  do iu = 1,nu
     u = u*urat
     ud(iu) = u
     dud(iu) = u*durat
     bus(iu) = bw(u,tstar)+xuv*(tstar/tuv)**4*bw(u,tuv)
  enddo
  !	modify dud(1) so integral over ud includes ud < ud(1)
  dud(1) = ud(1)/four+dud(1)/two
  !	initialize phab, phsc, reading from ac.out and as.out
  open(unit=10,file='ac.out',access='sequential')
  read(10,'(1x)')
  do ia = 1,la
     a = ad(ia)
     !	skip every other a
     do iu = nu,1,-1
        read(10,'(///)')
     enddo
     do iu = nu,1,-1
        !	read every 4th line
        read(10,'(6e12.4///)') amie,wlen,qext,qabs,qscat,cosscat
        if(doprint.and.((abs(1.0e+04-amie/a).gt.one) &
             .or.(abs(1.0e+04-ud(iu)*wlen).gt.one))) &
             print '(2i6,1p,4e10.2)', ia,iu,a,amie,ud(iu),wlen
        phab(iu,ia) = qabs
        !	decrease qscat to account for lowered effect of forward scattering
        if((cosscat.gt.zero).and.(cosscat.lt.one)) &
             qscat = (one-cosscat)*qscat
        phsc(iu,ia) = qscat
     enddo
  enddo
  close(unit=10)
  open(unit=10,file='as.out',access='sequential')
  read(10,'(1x)')
  do ia = la+1,na
     a = ad(ia)
     do iu = nu,1,-1
        read(10,'(///)')
     enddo
     do iu = nu,1,-1
        read(10,'(6e12.4///)') amie,wlen,qext,qabs,qscat,cosscat
        if(doprint.and.((abs(1.0e+04-amie/a).gt.one) &
             .or.(abs(1.0e+04-ud(iu)*wlen).gt.one))) &
             print '(2i6,1p,4e10.2)', ia,iu,a,amie,ud(iu),wlen
        phab(iu,ia) = qabs
        if((cosscat.gt.zero).and.(cosscat.lt.one)) &
             qscat = (one-cosscat)*qscat
        phsc(iu,ia) = qscat
     enddo
  enddo
  close(unit=10)
  !	finer grid for last iteration
  w = w0
  do iu = 1,nu
     w = w*wrat
     wd(iu) = w
  enddo
  open(unit=10,file='ac.out',access='sequential')
  read(10,'(1x)')
  do ia = 1,la
     a = ad(ia)
     do iu = nu,1,-1
        read(10,'(///)')
     enddo
     !	skip to 31.6um
     do iu = 1,96
        read(10,'(1x)')
     enddo
     do iu = nu,1,-1
        read(10,'(5e12.4)') amie,wlen,qext,qabs,qscat
        if(doprint.and.((abs(1.0e+04-amie/a).gt.one) &
             .or.(abs(1.0e+04-wd(iu)*wlen).gt.one))) &
             print '(2i6,1p,4e10.2)', ia,iu,a,amie,wd(iu),wlen
        !	neglect scattering at line wavelengths
        phid(iu,ia) = qabs
     enddo
     do iu = 1,96
        read(10,'(1x)')
     enddo
  enddo
  close(unit=10)
  open(unit=10,file='as.out',access='sequential')
  read(10,'(1x)')
  do ia = la+1,na
     a = ad(ia)
     do iu = nu,1,-1
        read(10,'(///)')
     enddo
     do iu = 1,96
        read(10,'(1x)')
     enddo
     do iu = nu,1,-1
        read(10,'(5e12.4)') amie,wlen,qext,qabs,qscat
        if(doprint.and.((abs(1.0e+04-amie/a).gt.one) &
             .or.(abs(1.0e+04-wd(iu)*wlen).gt.one))) &
             print '(2i6,1p,4e10.2)', ia,iu,a,amie,wd(iu),wlen
        phid(iu,ia) = qabs
     enddo
     do iu = 1,96
        read(10,'(1x)')
     enddo
  enddo
  close(unit=10)

  !	calculate emis = 1-albedo averaged over stellar spectrum
  emissum = zero
  emissil = zero
  sumbus = zero
  abssum = zero
  do iu = 1,nu
     busdud = bus(iu)*dud(iu)
     opac = zero
     scat = zero
     opacsil = zero
     scatsil = zero
     do ia = 1,na
        area = pi*ad(ia)**2
        popsig = popd(ia)*area*phab(iu,ia)
        if(mod(ia,2).eq.0) &
             spec(iu,ia/2) = max(-1.0d+01,(slog10(popsig)+2.4d+01))
        opac = opac+popsig
        if(ia.gt.la) opacsil = opacsil+popsig
        popsig = popd(ia)*area*phsc(iu,ia)
        scat = scat+popsig
        if(ia.gt.la) scatsil = scatsil+popsig
     enddo
     spec(iu,na/4) = max(-1.0d+01,(slog10(opac)+2.4d+01))
     spec(iu,na/2) = max(-1.0d+01,(slog10(opacsil)+2.4d+01))
     emisi = opac/(opac+scat)
     emis(iu) = emisi
     emissum = emissum+busdud*emisi
     emissil = emissil+busdud*opacsil/(opacsil+scatsil)
     abssum = abssum+busdud*sqrt(emisi)
     sumbus = sumbus+busdud
  enddo
  emiss = emissum/sumbus
  emissil = emissil/sumbus
  abss = abssum/sumbus
  treem = tsubli/two**quart
  reemiss = half*abss*(treem/tstar)**4
  do iu = 1,nu
     rebus(iu) = bus(iu) &
          +sqrt(emis(iu))*(reemiss*bw(ud(iu),treem)-bus(iu))
  enddo
  if(doprint) print '(" dust albedos and reflectivities:",6f7.3)', &
       one-emiss,one-emissil,one-sqrt(emiss),one-sqrt(emissil), &
       one-abss

  !	plot opacity and populations
  if(doprint) then
     tauv = zero
     tausil = zero
     taufir = zero
     wfir = 1.0d+02
     iufir = slog10(wfir/u0)/dlogu+half
     do ia = 1,na
        tauv = tauv+popd(ia)*pi*ad(ia)**2*phab(iuv,ia)
        tausil = tausil+popd(ia)*pi*ad(ia)**2*phab(iusil,ia)
        taufir = taufir+popd(ia)*pi*ad(ia)**2*phab(iufir,ia)
     enddo
     print '(" Tauv/N =",1p,4e10.2)', &
          tauv,tauv/xmg,tausil/xmg,taufir/xmg
     call plotspec(spec,mu,nu,na/2,1,zero,'')
     call sleep(4)
     do iu = 1,nu
        do ia = 2,na,2
           spec(iu,ia/2) = max(-5.,slog10(phab(iu,ia)))
        enddo
     enddo
     call plotspec(spec,mu,nu,na/2,1,zero,'')
  endif

  return
end subroutine dustinit



subroutine stepd(fwi,ix,iy,iz,igr)

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)

  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /xj/ xju,xjp,xjq,xjr,xk
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /vels/ wr(mt,mr,mg),wth(mt,mr,mg),wph(mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /exptab/ expi(10239),too
  dimension fwi(mw,ml),ffi(ml)
  logical good,doprint,badnum
  logical starlt,newcell

  parameter (pi = 3.14159265d+00)
  parameter (sqrtpi = 1.772454d+00)
  parameter (sqrt2 = 1.414214d+00)
  parameter (alog2 = 0.6931472d+00)
  parameter (small = 1.0d-03)
  parameter (tiny = 1.0d-08)
  parameter (zilch = 1.0d-200)
  parameter (hun = 1.0d+02)
  parameter (big = 5.0d+03)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (eighth = 0.125d+00)
  parameter (au = 1.496d+13)

  save kt,kr,kg

  doprint = (myrank.eq.0)
  starlt = (iy.gt.nx9/2)
  jg = abs(igr)
  if(jg.le.1) jg = ng9
  if(starlt) then
     lx = nx9
     dx = rstar/four
     if(jg.eq.ng9) then
        jg = ng9
        lz = nz9
        dz = dz9
        rmx = nr9*dr9
     else
        twig = two**jg
        lz = nz
        dz = dz0*twig
        rmx = nr*dr0*twig
     endif
  elseif(jg.eq.ng9) then
     jg = ng9
     lx = nx9
     dx = dx9
     lz = nz9
     dz = dz9
     rmx = nr9*dr9
  else
     twig = two**jg
     lx = nx
     dx = dx0*twig
     lz = nz
     dz = dz0*twig
     rmx = nr*dr0*twig
  endif
  ly = lx/2
  !	finer xy steps in middle of grid
  if(igr.lt.0) dx = dx/two
  dx2 = dx/two
  dz2 = dz/two
  ds = dz
  x = dx2*(2*ix-lx-1)
  y = dx2*(2*iy-lx-1)
  z = dz2*(2*iz-lz-1)
  r = sqrt(x**2+y**2+z**2)
  crot = cos(rot)
  srot = sin(rot)
  costh = abs(crot*z+srot*x)/r
  if(costh.gt.(nt*dcost)) return
  sinth = sqrt(one-costh**2)
  dcosth = dcost
  cosmx = nt*dcos9
  if(jg.le.ng) then
     if(r.le.rmx) then
        ig = jg
        dr = dr0*twig
        lr = nr
        gwt = one
     elseif(jg.lt.ng) then
        ig = jg+1
        dr = two*dr0*twig
        lr = nr
        gwt = eighth
     else
        return
     endif
  else
     if(r.gt.rmx) then
        ig = 2
        dr = four*dr0
        lr = nr
        gwt = (dz9/(four*dz0))*(dx9/(four*dx0))**2
     elseif(abs(costh).gt.cosmx) then
        ig = 1
        dr = two*dr0
        lr = nr
        gwt = (dz9/(two*dz0))*(dx9/(two*dx0))**2
     else
        ig = ng9
        dr = dr9
        lr = nr9
        !            gwt = (dz9/(two*dz0))*(dx9/(two*dx0))**2
        gwt = one/nn9
        dcosth = dcos9
     endif
  endif
  if(starlt) then
     if((x.gt.rstar).or.(r.lt.rstar)) return
     gwt = sqrt(one-(x/rstar)**2)
  elseif(igr.lt.0) then
     gwt = gwt/four
  endif

  ri = r/dr+half
  ir = nint(ri)
  if((ir.lt.1).or.(ir.gt.lr)) return
  !        dir = ri-ir
  !        if(dir.lt.zero) then
  !          dir = -dir
  !          jr = max(ir-1,1)
  !        else
  !          jr = min(ir+1,lr)
  !        endif
  ti = nt-abs(costh)/dcosth+half
  it = nint(ti)
  if((it.lt.1).or.(it.gt.nt)) return
  !        dit = ti-it
  !        if(dit.lt.zero) then
  !          dit = -dit
  !          jt = max(it-1,1)
  !        else
  !          jt = min(it+1,nt)
  !        endif
  !        dirt = one-dir-dit
  if((it.eq.kt).and.(ir.eq.kr).and.(ig.eq.kg)) then
     newcell = .false.
  else
     newcell = .true.
     kt = it
     kr = ir
     kg = ig
  endif

  !	let star absorb, but not emit
  !	put starlight in at start of starlight rays
  if(starlt) then
     continue
  elseif((jg.eq.ng9).and.(z.gt.zero).and.(z.lt.dz)) then
     !	crossing midplane
     taucont = zero
     xi = abs(x)-dx2
     yi = abs(y)-dx2
     ri = sqrt(xi**2+yi**2)
     if(ri.lt.rstar)then
        !	inner corner passes through star
        xo = xi+dx
        yo = yi+dx
        ro = sqrt(xo**2+yo**2)
        if(ro.lt.rstar) then
           !	entire cell passes through star
           astar = one
        elseif((abs(x).lt.dx).and.(abs(y).lt.dx)) then
           !	on one of inner 4 cells
           if(rstar.lt.dx) then
              astar = (pi/4.)*rstar**2/dx**2
           else
              astar = one-(sqrt2-rstar/dx)**2
           endif
        else
           !	calculate fraction of cell passing through star
           ri = sqrt(x**2+y**2)-dx2
           ro = ri+dx
           if(ri.gt.rstar) then
              astar = zero
           elseif(ro.lt.rstar) then
              astar = one
           else
              astar = (rstar-ri)/dx
           endif
        endif
        if(astar.gt.zero) then
           !	part of cell passed through star
           do iu = 1,nu
              fwi(iu,1) = fwi(iu,1)*(one-astar)
           enddo
           if((it.lt.1).or.(it.gt.nt)) return
           do iu = 1,nu
              ff(iu,it,ir,ig) = ff(iu,it,ir,ig)+gwt*fwi(iu,1)
           enddo
           fn(it,ir,ig) = fn(it,ir,ig)+gwt
           return
        endif
     else
        astar = zero
     endif
  elseif(r.lt.rstar) then
     !	still in star off of midplane
     do iu = 1,nu
        fwi(iu,1) = zero
     enddo
     return
  endif

  !	not on star
  !	radiative transfer in cell
  !	optical depth reduction factor is built into opa and sca
  if(opa(iuv,it,ir,ig)*ds.gt.tiny) then
     do iu = 1,nu
        fwi0 = fwi(iu,1)
        opac = opa(iu,it,ir,ig)
        scat = sca(iu,it,ir,ig)
        if(starlt) then
           sfun = zero
        else
           sfun = swd(iu,it,ir,ig)
        endif
        !	interpolation across sublimation front causes problems
        !          if((ig.gt.jg).and.(ig.le.ng)) then
        !            opac = dirt*opac+dir*opa(iu,it,jr,ig)+dit*opa(iu,jt,ir,ig)
        !            scat = dirt*scat+dir*sca(iu,it,jr,ig)+dit*sca(iu,jt,ir,ig)
        !            if(iy.le.ly) &
        !              sfun = dirt*sfun+dir*swd(iu,it,jr,ig)+dit*swd(iu,jt,ir,ig)
        !          endif
        if(sfun.lt.zilch) sfun = zero
        opacs = opac+scat
        taud = opacs*ds
        if(taud.lt.small) then
           fwi1 = fwi0+(sfun-fwi0)*taud
           fwi2 = (fwi0+fwi1)/two
        else
           !            expd = sexp(-taud)
           arg = hun*taud
           if(arg.lt.big) then
              iarg = int(arg)
              darg = (arg-iarg)/hun
              expd = (one-darg+darg**2/too)*expi(iarg+1)
              fwi1 = fwi0*expd+sfun*(one-expd)
           else
              fwi1 = sfun
           endif
           !	Yes.  sfun does belong here.
           fwi2 = (fwi0-fwi1)/taud+sfun
        endif
        if(fwi1.lt.zilch) fwi1 = zero
        fwi(iu,1) = fwi1
        if(starlt) then
           ff(iu,it,ir,ig) = ff(iu,it,ir,ig)+gwt*fwi2
        else
           !	try using incoming radiation field?
           !          ff(iu,it,ir,ig) = ff(iu,it,ir,ig)+gwt*fwi0
           !	try using radiation field entering r-th cell?
           if(newcell) fwi(iu,2) = fwi0
           ff(iu,it,ir,ig) = ff(iu,it,ir,ig)+gwt*fwi(iu,2)
        endif
     enddo  !  iu
  else
     do iu = 1,nu
        if(newcell) fwi(iu,2) = fwi(iu,1)
        ff(iu,it,ir,ig) = ff(iu,it,ir,ig)+gwt*fwi(iu,2)
     enddo
  endif

  fn(it,ir,ig) = fn(it,ir,ig)+gwt

  return
end subroutine stepd



subroutine gastemp(it,ir,ig,iamax,tsubli,tgi,tdi,hcgas,lastit)
  !	calculate equilibrium gas and dust temperatures
  !	holding pressure constant

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /heat/ gmmdot,acom,pxr,axr,bxr,epspe,agas,sigma, &
       colin,colup,xco,xwat
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  dimension tda(ma),popa(ma),opaci(mu),scati(mu)
  logical lastit,doprint
  logical badnum

  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (quart = 0.25d+00)
  parameter (fifth = 0.2d+00)
  parameter (small = 1.0d-03)
  parameter (zilch = 1.0d-100)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (five = 5.0d+00)
  parameter (ten = 1.0d+01)
  parameter (hun = 1.0d+02)
  parameter (pi = 3.14159265d+00)
  parameter (bk = 1.3807d-16)
  parameter (sigsb = 5.670d-05)
  parameter (xmg = 4.0d-24)
!!$ TODO: modularize dust/gas heating/cooling and gastemp
!!$ Declare variables for components of heating
!!$ HeatGas(PE/XR/Accr)Array  = heating of gas due to photoelectric effect/xrays/
!!$ viscous accretion for plotting as heating maps
!!$ Heat(Gas/Dust)TotArray = total heating of gas/dust 
!!$ CoolDustTotArray       = total cooling of dust due to radiation
!!$ (Heat/Cool)TotArray    = total heating/cooling including all gas and dust
!!$ AccomArray = heat exchange due to accomodation coefficient between gas and dust
  COMMON /GasTempArr/ &
       HeatGasPEArray(mt, mr, mg), HeatGasXRArray(mt, mr, mg), &
       HeatGasAccrArray(mt, mr, mg), HeatGasTotArray(mt, mr, mg), &
       HeatDustTotArray(mt, mr, mg), HeatTotArray(mt, mr, mg), &
       CoolDustTotArray(mt, mr, mg), CoolTotArray(mt, mr, mg), &
       AccomArray(mt, mr, mg)

  tpi = two*pi
  fpi = four*pi
  doprint = (myrank.eq.0)

  !	min and max tg, td
  tgmin = ten
  tgmax = tstar
  tdmin = ten
  tdmax = tsubli
  popmin = 1.0d-50

  if(badnum(tdi).or.(tdi.gt.tdmax)) tdi = tdmax
  tdi = max(tdmin,tdi)
  if(badnum(tgi).or.(tgi.gt.tgmax)) tgi = tgmax
  tgi = max(tgmin,tgi)
  tg0 = tgi
  dens0 = dg(it,ir,ig)
  pres = dens0*tgi
  dens = pres/tgi
  if(ig.eq.ng9) then
     dr = dr9
  else
     dr = dr0*two**ig
  endif
  r = dr*(ir+half)
  if((r.le.rstar).or.(dens.eq.zero)) goto 90
  !	initialize opac and scat
  dd0 = dd(it,ir,ig)
  popsum = zero
  do ia = 1,na
     !	include settling factor in popa
     popa(ia) = condens(ia,it,ir,ig)*popd(ia)*sexp(-dd0*ad(ia)) &
          *pi*ad(ia)**2
     popsum = popsum+popa(ia)
  enddo
  do iu = 1,nu
     opac = zero
     scat = zero
     if(popsum.gt.popmin) then
        do ia = 1,na
           opac = opac+popa(ia)*phab(iu,ia)
           scat = scat+popa(ia)*phsc(iu,ia)
        enddo
     endif
     opaci(iu) = opac
     scati(iu) = scat
     if(nit.eq.-1) then
        opa(iu,it,ir,ig) = dens*opac
        sca(iu,it,ir,ig) = dens*scat
     endif
  enddo
  if((popsum.lt.zilch).or.(dens.lt.small)) then
     tgi = tstar*(rstar/r)**0.4
     tdi = tsubli
     goto 90
  endif
  !	heating and cooling powers/gas particle
  hdust = zero
  hpe = zero
  npe = nu-4
  do iu = nu,npe,-1
     opadu = opaci(iu)*dud(iu)
     hdust = hdust+opadu*fpi*gg(iu,it,ir,ig)
  enddo
  !	epspe should depend on dens and maybe ad
  if(hdust.gt.zilch) hpe = epspe*hdust
  hdust = hdust-hpe
  do iu = npe-1,1,-1
     opadu = opaci(iu)*dud(iu)
     hdust = hdust+opadu*fpi*gg(iu,it,ir,ig)
  enddo
  !	now include ud < ud(1) with modified dud(1)
  !        hdust = hdust+opaci(1)*ud(1)*fpi*gg(1,it,ir,ig)/five
  hxr = (pxr/(fpi*r**2))*((axr/two)/(axr*colin/two+one)**2)
  if(sigma.gt.zero) then
     haccr = gmmdot/(fpi*r**3*sigma)
  else
     haccr = zero
  endif
  hgas = hpe+hxr+haccr

!!$ STH: define arrays for heating of gas
  HeatGasPEArray(it, ir, ig) = hpe
  HeatGasXRArray(it, ir, ig) = hxr
  HeatGasAccrArray(it, ir, ig) = haccr
  HeatGasTotArray(it, ir, ig) = hgas

  if(hdust.lt.zilch) hdust = zero
  if(hgas.lt.zilch) hgas = zero
  htot = hgas+hdust

!!$ STH: define arrays for heating of dust and total heating
  HeatDustTotArray(it, ir, ig) = hdust
  HeatTotArray(it, ir, ig) = htot

  if(htot.le.zero) then
     tgi = tsubli
     tdi = tsubli
     goto 90
  endif
  dens = pres/tgi
  cgas = cooling(dens,tgi,it,ir,ig)
  !	I did have a four in here.  I think it was wrong.
  !	I''m not sure about the two.
  acgd = dens*popsum*sqrt(two*bk*tgi/xmg)*acom*2.5*bk
  if(acgd.le.zilch) then
     !	no dust and/or no gas, or maybe no coupling
     acgd = zero
     if(hgas*cgas.gt.zero) then
        !	must have x-ray heating but no dust
        iit = 0
112     iit = iit+1
        cgas = cooling(dens,tgi,it,ir,ig)
        tgi = tgi*(hgas/cgas)**(half/max(agas,half))
        dens = pres/tgi
        if((iit.lt.16).and.(tgi.gt.tgmin).and.(tgi.lt.tgmax) &
             .and.(abs(hgas/cgas-one).gt.small)) goto 112
        if(cgas.gt.zero) then
           tgi = min(tgmax,max(tgmin,tgi))
        else
           tgi = tgmax
        endif
     else
        !	no gas or no gas heating
        hgas = zero
        tgi = tgmin
     endif
     dens = pres/tgi
     if(hdust.gt.zero) then
        !	must have dust but no coupling to gas? doesn''t seem likely
        iit = 0
114     iit = iit+1
        cdust = zero
        do iu = 1,nu
           opadu = opaci(iu)*dud(iu)
           cdust = cdust+opadu*fpi*bw(ud(iu),tdi)
        enddo
        tdi = tdi*(hdust/cdust)**fifth
        if((iit.lt.16).and.(abs(hdust/cdust-one).gt.small)) goto 114
     else
        hdust = zero
        tdi = tsubli
     endif
  else ! if (acgd .le. zilch)
     !	calculate tg and td including gas-dust heat flow
     iit = 0
110  iit = iit+1
     cdust = zero
     do iu = 1,nu
        opadu = opaci(iu)*dud(iu)
        cdust = cdust+opadu*fpi*bw(ud(iu),tdi)
     enddo
     cgas = cooling(dens,tgi,it,ir,ig)
     dtd = (hdust+acgd*(tgi-tdi)-cdust)/(five*cdust/tdi+acgd)
     agd = max((agas*cgas/tgi+acgd),half*cgas/tgi)
     dtg = (hgas+acgd*(tdi-tgi)-cgas)/agd
     dtmx = tdi/four
     tdi = tdi+min(dtmx,max(-dtmx,dtd))/two
     tdi = min(tdmax,max(tdmin,tdi))
     dtmx = tgi/four
     tgi = tgi+min(dtmx,max(-dtmx,dtg))/two
     tgi = min(tgmax,max(tgmin,tgi))
     dens = pres/tgi
     if(badnum(tdi).or.badnum(tgi).or.(tgi.le.zero)) then
        print '("tgi",4i4,1p,6e10.2/7e10.2)', &
             it,ir,ig,iit,hdust,cdust,hgas,cgas,dtd,dtg, &
             dens,popsum,dtmx*four,tdi,tgi
        tdi = hun
        tgi = hun
        goto 190
     endif
     if((abs(dtg/tgi).gt.small).and.(iit.lt.16)) goto 110
190 endif
  hcgas = hgas-cgas
  if(badnum(tdi).or.(tdi.gt.tdmax)) tdi = tdmax
  tdi = max(tdmin,tdi)
  if(badnum(tgi).or.(tgi.gt.tgmax)) tgi = tgmax
  tgi = max(tgmin,tgi)
  dens = pres/tgi
  !	tg(it,ir,ig) = tgi  !  in main
  !	dg(it,ir,ig) = dens  !  in hydro equil calc
  !	calculate individual grain temperatures
  !	using heat flows per grain cross section (pi*a**2)
  acgd = dens*sqrt(two*bk*tgi/xmg)*acom*2.5*bk

!!$ STH: define gas-dust accomodation array
  CoolDustTotArray(it, ir, ig) = cdust
  CoolTotArray(it, ir, ig) = cgas + cdust
  AccomArray(it, ir, ig) = acgd

  iamax = 0
  do ia = 1,na
     if(popa(ia).gt.zero) then
        tdia = tdi
        hdia = zero
        do iu = 1,nu
           hdia = hdia+phab(iu,ia)*fpi*gg(iu,it,ir,ig)*dud(iu)
        enddo
        iit = 0
130     iit = iit+1
        cdia = zero
        do iu = 1,nu
           cdia = cdia+phab(iu,ia)*fpi*bw(ud(iu),tdia)*dud(iu)
        enddo
        dcdia = five*cdia/tdia+acgd
        dtdia = (hdia-cdia+acgd*(tgi-tdia))/dcdia
        dtmx = tdia/four
        tdia = tdia+min(dtmx,max(-dtmx,dtdia))
        if(badnum(tdia).or.(tdia.le.zero)) then
           print '("tdia",5i4,1p,4e10.2/7e10.2)', &
                it,ir,ig,ia,iit,hdia,cdia,dcdia,tdia, &
                tgi,tdi,dens,acgd,hgas,cgas
           stop
        endif
        if((abs(dtdia/tdia).gt.small).and.(iit.lt.16)) goto 130
        !	condens is now set in main
        !	but should I let small grains sublimate here?
        if(tdia.gt.tsubli) then
           iamax = ia
           !              tdia = tsubli
        endif
        tda(ia) = tdia
     else
        tda(ia) = tdi
     endif
  enddo

  if(nit.lt.0) then
     if((taucont.eq.zero).and.(popsum.gt.zero)) then
        !	crossing sublimation front; set taufac
        opacv = opaci(iuv)
        scatv = scati(iuv)
        dtauv = sqrt(opacv*(opacv+scatv))*dens*dr
        krmx = 16
        dtaumx = one/krmx
        if(ig.ne.ng9) krmx = krmx/nn9
        if(dtauv.gt.dtaumx) then
           taufac = dtaumx/dtauv
           dtaufac = sqrt(two)
           taufac = taufac/dtaufac
           krmx = min(krmx,int(-log(taufac)/log(dtaufac)))
           do kr = 1,krmx
              taufac = taufac*dtaufac
              jr = ir+kr-1
              if(ig.eq.ng9) then
                 if(jr.le.nr9) then
                    opl(ml,it,jr,ig) = taufac
                 else
                    jr = (jr-1)/(2*nn9)+1
                    jt = nt-(nt-it)/nn9
                    opl(ml,jt,jr,2) = taufac
                 endif
              else
                 if(jr.le.nr) then
                    opl(ml,it,jr,ig) = taufac
                 elseif(ig.lt.ng) then
                    jg = ig+1
                    jr = (jr-1)/2+1
                    opl(ml,it,jr,jg) = taufac
                 endif
              endif
           enddo
        endif
     endif
  endif
  densfac = dens*opl(ml,it,ir,ig)
  dd0 = dd(it,ir,ig)
  if(lastit) then
     !	use phid for opa and ignore scattering
     do iu = 1,nu
        opac = zero
        sfun = zero
        do ia = 1,na
           condi = condens(ia,it,ir,ig)*sexp(-dd0*ad(ia))
           if(condi.gt.zero) then
              popai = condi*popd(ia)*pi*ad(ia)**2
              if(popai.gt.zero) then
                 opac = opac+popai*phid(iu,ia)
                 sfun = sfun+popai*phid(iu,ia)*bw(wd(iu),tda(ia))
              endif
           endif
        enddo
        opa(iu,it,ir,ig) = opac*densfac
        sca(iu,it,ir,ig) = zero
        if(opac.gt.zero) then
           swd(iu,it,ir,ig) = sfun/opac
        else
           swd(iu,it,ir,ig) = bw(wd(iu),tsubli)
        endif
     enddo
  else
     do iu = 1,nu
        opac = zero
        scat = zero
        sfun = zero
        do ia = 1,na
           popai = condens(ia,it,ir,ig)*popd(ia)*sexp(-dd0*ad(ia)) &
                *pi*ad(ia)**2
           if(popai.gt.zero) then
              opac = opac+popai*phab(iu,ia)
              scat = scat+popai*phsc(iu,ia)
              sfun = sfun+popai*phab(iu,ia)*bw(ud(iu),tda(ia))
           endif
        enddo
        opa(iu,it,ir,ig) = opac*densfac
        sca(iu,it,ir,ig) = scat*densfac
        if((opac+scat).gt.zero) then
           swd(iu,it,ir,ig) = &
                (sfun+scat*gg(iu,it,ir,ig))/(opac+scat)
        else
           swd(iu,it,ir,ig) = gg(iu,it,ir,ig)
        endif
     enddo
  endif

  !	tgi was oscillating.  this seems to cure it.
  tgi = (tg0+tgi)/two
  return

90 tdi = min(tdmax,max(tdmin,tdi))
  tgi = min(tgmax,max(tgmin,tgi))
  hcgas = zero
  do iu = 1,nu
     if(lastit) then
        w = wd(iu)
     else
        w = ud(iu)
     endif
     opa(iu,it,ir,ig) = zero
     sca(iu,it,ir,ig) = zero
     swd(iu,it,ir,ig) = bw(w,tdi)
  enddo
  iamax = na+1

  return

end subroutine gastemp



!!$ TODO: make cooling module with funcs for cooling tot and each process
!!$ TODO: allow cooling to be negative (i.e. as heating)
function cooling(dg0,tg0,it,ir,ig)

!!$ Declare modules used.
  USE ModAbund
  USE ModCoolCII
  USE ModCoolOI

  !	gas cooling by H2O, CO, and H2 Neufeld & Kaufman, 1993
  !	per gas particle, T dependance at constant pressure

  implicit real*8 (a-h,o-z)
  parameter (mt = 192)
  parameter (mr = 128)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (mu = 64)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /heat/ gmmdot,acom,pxr,axr,bxr,epspe,agas,sigma, &
       colin,colup,xco,xwat
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (ten = 1.0d+01)
  parameter (pi = 3.14159265d+00)
  parameter (bk = 1.3807d-16)
  parameter (hck = 1.439d+00)
  parameter (au = 1.496d+13)
!!$ TODO: Remove cooling arrays to main program by putting cooling into modular functions. For now cooling arrays are in outdated common block. Do same for heating.
!!$ Declare variables for components of cooling
!!$ CoolGas(CII/OI)  = cooling due to emission from CII/OI in units of erg s^-1 (gas particle)^-1
!!$ dCoolGas(CII/OI) = cooling due to emission from CII/OI but with 1.001*temperature for calculating derivative
!!$ Abund(CII/OI/e/H/H2) = abundances of CII/OI/e/H/H2 relative to all gas particles
!!$ PosInf = underflow from writing procedures by defining a positive infimum (greatest lower bound of the postive numbers)
  REAL :: &
       CoolGasCII, dCoolGasCII, CoolGasOI, dCoolGasOI, &
       AbundCII, AbundOI, Abunde, AbundH, AbundH2, &
       PosInf = 1.E-99
  
!!$ CoolGas(H2O/CO/H2)(Rot/Vib)Array = cooling due to H2O/CO/H2
!!$ rotation/vibration for plotting as cooling maps
!!$ CoolGas(CII/OI)Array = cooling due to CII/OI fine structure transition
!!$ CoolGasTotArray      = total cooling due to all processes for plotting in cooling map
  COMMON /CoolGasArr/ &
       CoolGasH2ORotArray(mt, mr, mg), CoolGasH2OVibArray(mt, mr, mg), &
       CoolGasCORotArray(mt, mr, mg),  CoolGasCOVibArray(mt, mr, mg), &
       CoolGasH2RotArray(mt, mr, mg),  CoolGasH2VibArray(mt, mr, mg), &
       CoolGasCIIArray(mt, mr, mg), CoolGasOIArray(mt, mr, mg), &
       CoolGasTotArray(mt, mr, mg)
!!$ Abund(CII/OI/e/H/H2)Array = abundances of CII/OI/e/H/H2 relative to all gas particles
  COMMON /AbundArr/ &
       AbundCIIArray(mt, mr, mg), AbundOIArray(mt, mr, mg), &
       AbundeArray(mt, mr, mg), &
       AbundHArray(mt, mr, mg), AbundH2Array(mt, mr, mg)

  logical badnum
  tpi = two*pi
  fpi = four*pi

  pres = dg0*tg0
  if(badnum(pres).or.(pres.le.zero)) then
     cooling = zero
     agas = one
     return
  endif
  if(colin*colup.gt.zero) then
!!$ STH: Lacy's approximation for colg good when disk is concave (flaring) but not when convex (inner rim). Affect of approximation is to reduce curvature at top of inner rim.
!!$ Numerator should be 2 for harmonic mean instead of 1.
     colg = one/(one/colin + one/colup)
  else
     colg = zero
  endif
  ds = colg/dg0
  deltat = 1.0d-03*tg0
  call startgr(ig,jg,kr,lr,lt,dr,dcosth)
  r = dr*(ir-half)
  dvturb = sqrt(dvturb0**2+dvturb1**2*au/r)

  !	H2O rotational cooling
  if(xwat.gt.zero) then
     tgref = 4.0d+02
     colref = 1.0d+24/dvturb
     tgas = tg0
     dens = pres/tgas
     xmol = xwat
     dmol = xmol*dens
     !	c0 = ten**(-23.42)*(tgi/400.)**((23.87-22.88)/log10(1000/200))
     tgif = log10(tgas/tgref)
     cold = log10(xmol*colg/colref+1.0d-04)
     c0 = ten**(-23.42+1.42*tgif)
     clte = ten**(-16.07+3.39*tgif-0.78*cold)
     cn = ten**(4.10+2.19*tgif-cold)
     ca = 0.39-0.20*tgif+0.01*cold
     !	assume dust is much less opaque than lines
     cwat = dmol/(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))
     !	repeat with 1.001*tgas for T dependance
     tgas = tg0+deltat
     dens = pres/tgas
     dmol = xmol*dens
     tgif = log10(tgas/tgref)
     !	cold = log10(xmol*colg/colref)
     c0 = ten**(-23.42+1.42*tgif)
     clte = ten**(-16.07+3.39*tgif-0.78*cold)
     cn = ten**(4.10+2.19*tgif-cold)
     ca = 0.39-0.20*tgif+0.01*cold
     dwat = dmol/(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))
  else
     cwat = zero
     dwat = zero
  endif

  !	CO rotational cooling
  if(xco.gt.zero) then
     tgref = 6.0d+02
     colref = 1.0d+24/dvturb
     tgas = tg0
     dens = pres/tgas
     xmol = xco
     dmol = xmol*dens
     tgif = log10(tgas/tgref)
     cold = log10(xmol*colg/colref+1.0d-02)
     c0 = ten**(-23.07+0.844*tgif)
     clte = ten**(-18.62+2.72*tgif-0.69*cold)
     cn = ten**(2.79+1.91*tgif-cold)
     ca = 0.46-0.08*tgif+0.06*cold
     cco = dmol/(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))
     !	repeat with 1.001*tgas for T dependance
     tgas = tg0+deltat
     dens = pres/tgas
     dmol = xmol*dens
     tgif = log10(tgas/tgref)
     c0 = ten**(-23.07+0.844*tgif)
     clte = ten**(-18.62+2.72*tgif-0.69*cold)
     cn = ten**(2.79+1.91*tgif-cold)
     ca = 0.46-0.08*tgif+0.06*cold
     dco = dmol/(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))
  else
     cco = zero
     dco = zero
  endif

  !	H2 rotational cooling
  tgref = 5.0d+02
  tgas = tg0
  dens = pres/tgas
  dmol = dens
  !	just a guess
  umol = 2000.
  iumol = 16.*(slog10(umol)-one)
  taudmol = sexp(-opa(iumol,it,ir,ig)*ds)
  tgif = log10(tgas/tgref)
  c0 = ten**(-24.64+2.27*tgif)
  clte = ten**(-22.13+3.85*tgif)
  cn = ten**(1.14+1.05*tgif)
  ca = 0.42-0.03*tgif
  chh = dmol*taudmol &
       /(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))
  !	repeat with 1.001*tgas for T dependance
  tgas = tg0+deltat
  dens = pres/tgas
  dmol = dens
  tgif = log10(tgas/tgref)
  c0 = ten**(-24.64+2.27*tgif)
  clte = ten**(-22.13+3.85*tgif)
  cn = ten**(1.14+1.05*tgif)
  ca = 0.42-0.03*tgif
  dhh = dmol*taudmol &
       /(one/c0+dens/clte+(dens/cn)**ca*(one/c0-cn/clte))

  !	H2O vibrational cooling
  if(xwat.gt.zero) then
     tgref = 4.0d+02
     colref = 1.0d+24/dvturb
     tgas = tg0
     dens = pres/tgas
     xmol = xwat
     dmol = xmol*dens
     umol = 1617.
     iumol = 16.*(slog10(umol)-one)
     taudmol = sexp(-opa(iumol,it,ir,ig)*ds)
     tgif = log10(tgas/tgref)
     cold = log10(xmol*colg/colref+1.0d-04)
     c0 = 1.03d-26*tgas*sexp(-47.5/tgas**0.333-2325./tgas)
     clte = ten**(-12.99+1.36*tgif-0.74*cold)*exp(-2325./tgas)
     ewat = dmol*taudmol/(one/c0+dens/clte)
     !	repeat with 1.001*tgas for T dependance
     tgas = tg0+deltat
     dens = pres/tgas
     dmol = xmol*dens
     tgif = log10(tgas/tgref)
     c0 = 1.03d-26*tgas*sexp(-47.5/tgas**0.333-2325./tgas)
     clte = ten**(-12.99+1.36*tgif-0.74*cold)*exp(-2325./tgas)
     fwat = dmol*taudmol/(one/c0+dens/clte)
  else
     ewat = zero
     fwat = zero
  endif

  !	CO vibrational cooling
  if(xco.gt.zero) then
     tgref = 4.0d+02
     colref = 1.0d+24/dvturb
     tgas = tg0
     dens = pres/tgas
     xmol = xco
     dmol = xmol*dens
     umol = 2142.
     iumol = 16.*(slog10(umol)-one)
     taudmol = sexp(-opa(iumol,it,ir,ig)*ds)
     tgif = log10(tgas/tgref)
     cold = log10(xmol*colg/colref+1.0d-04)
     c0 = 1.83d-26*tgas*sexp(-68.0/tgas**0.333-3080./tgas)
     clte = ten**(-13.44+0.96*tgif-0.83*cold)*exp(-3080./tgas)
     eco = dmol*taudmol/(one/c0+dens/clte)
     !	repeat with 1.001*tgas for T dependance
     tgas = tg0+deltat
     dens = pres/tgas
     dmol = xmol*dens
     tgif = log10(tgas/tgref)
     c0 = 1.83d-26*tgas*sexp(-68.0/tgas**0.333-3080./tgas)
     clte = ten**(-13.44+0.96*tgif-0.83*cold)*exp(-3080./tgas)
     fco = dmol*taudmol/(one/c0+dens/clte)
  else
     eco = zero
     fco = zero
  endif

  !	H2 vibrational cooling
  tgas = tg0
  dens = pres/tgas
  dmol = dens
  umol = 4680.
  iumol = 16.*(slog10(umol)-one)
  taudmol = sexp(-opa(iumol,it,ir,ig)*ds)
  tgif = log10(tgas/tgref)
  c0 = 1.19d-24*sqrt(tgas) &
       *sexp(-1.81d+04/(tgas+1190.)-5976./tgas)
  clte = 1.10d-18*exp(-6744./tgas)
  ehh = dmol*taudmol/(one/c0+dens/clte)
  !	repeat with 1.001*tgas for T dependance
  tgas = tg0+deltat
  dens = pres/tgas
  dmol = dens
  c0 = 1.19d-24*sqrt(tgas) &
       *sexp(-1.81d+04/(tgas+1190.)-5976./tgas)
  clte = 1.10d-18*exp(-6744./tgas)
  fhh = dmol*taudmol/(one/c0+dens/clte)

!!$ Calculate total cooling from all cooling modules
!!$ TODO: make other cooling processes into modularized subroutines
!!$ for gg array, lambda = 10^3 10^(-4n/64) in microns for n = 1,2,...64
!!$ TODO: allow radiative heating of gas though atomic transitions.
!!$ For now, cooling must be non-negative.

!!$ Calculate CII cooling
!!$ gg frequency index nu for 158 microns is iu = 13
  CALL CalcCoolCII(ngas = dg0, Tempgas = tg0, Jw = gg(13, it, ir, ig), &
       Ntostar = colg, CoolCII = CoolGasCII)
  CoolGasCII = MAX(CoolGasCII, 0.)
  CALL CalcCoolCII(ngas = dg0, Tempgas = tg0 + deltat, Jw = gg(13, it, ir, ig), &
       Ntostar = colg, CoolCII = dCoolGasCII)
  dCoolGasCII = MAX(dCoolGasCII, 0.)

!!$ Calculate OI cooling
!!$ for wavelength of upper to lower transition 2Pupr,lwr:
!!$ 02: gg frequency index nu for 44  microns is iu = 22
!!$ 01: gg frequency index nu for 146 microns is iu = 13
!!$ 12: gg frequency index nu for 63  microns is iu = 19
  CALL CalcCoolOI(ngas = dg0, Tempgas = tg0, &
       Jw02 = gg(22, it, ir, ig), Jw01 = gg(13, it, ir, ig), Jw12 = gg(19, it, ir, ig), &
       Ntostar = colg, CoolOI = CoolGasOI)
  CoolGasOI = MAX(CoolGasOI, 0.)
  CALL CalcCoolOI(ngas = dg0, Tempgas = tg0, &
       Jw02 = gg(22, it, ir, ig), Jw01 = gg(13, it, ir, ig), Jw12 = gg(19, it, ir, ig), &
       Ntostar = colg, CoolOI = dCoolGasOI)
  dCoolGasOI = MAX(dCoolGasOI, 0.)

!!$ Components of total cooling:
!!$ cwat = H2O rotational  cooling
!!$ ewat = H20 vibrational cooling
!!$ cco  = CO  rotational  cooling
!!$ eco  = CO  vibrational cooling
!!$ chh  = H2  rotational  cooling
!!$ ehh  = H2  vibrational cooling
!!$ CoolGasCII = cooling from CII
!!$ CoolGasOI  = cooling from OI
  cooling = cwat+cco+chh+ewat+eco+ehh + CoolGasCII + CoolGasOI

!!$ TODO: Move cooling arrays to main program by putting cooling into modular functions. For now cooling arrays are in outdated common block. Do same for heating.
!!$ Write cooling arrays
!!$ Avoid underflow from writing procedures by restricting postive values to PosInf
!!$ Do not allow negative values for cooling  
  cwat = MAX(cwat, 0.)
  IF (cwat > 0.) cwat = MAX(cwat, PosInf)
  CoolGasH2ORotArray(it, ir, ig) = cwat

  ewat = MAX(ewat, 0.)
  IF (ewat > 0.) ewat = MAX(ewat, PosInf)
  CoolGasH2OVibArray(it, ir, ig) = ewat

  cco = MAX(cco, 0.)
  IF (cco > 0.)  cco = MAX(cco, PosInf)
  CoolGasCORotArray(it, ir, ig)  = cco

  eco = MAX(eco, 0.)
  IF (eco > 0.)  eco = MAX(eco, PosInf)
  CoolGasCOVibArray(it, ir, ig)  = eco

  chh = MAX(chh, 0.)
  IF (chh > 0.)  chh = MAX(chh, PosInf)
  CoolGasH2RotArray(it, ir, ig)  = chh

  ehh = MAX(ehh, 0.)
  IF (ehh > 0.)  ehh = MAX(ehh, PosInf)
  CoolGasH2VibArray(it, ir, ig)  = ehh

  CoolGasCII = MAX(CoolGasCII, 0.)
  IF (CoolGasCII > 0.) CoolGasCII = MAX(CoolGasCII, PosInf)
  CoolGasCIIArray(it, ir, ig)    = CoolGasCII

  CoolGasOI = MAX(CoolGasOI, 0.)
  IF (CoolGasOI > 0.) CoolGasOI   = MAX(CoolGasOI, PosInf)
  CoolGasOIArray(it, ir, ig)     = CoolGasOI

  cooling = MAX(cooling, 0.)
  IF (cooling > 0.) cooling = MAX(cooling, PosInf)
  CoolGasTotArray(it, ir, ig)    = cooling

!!$ Write abundances
  CALL CalcAbund(Ntostar = colg, &
       AbundCII = AbundCII, AbundOI = AbundOI, &
       Abunde = Abunde, AbundH = AbundH, AbundH2 = AbundH2)
  AbundCIIArray(it, ir, ig) = AbundCII
  AbundOIArray(it, ir, ig)  = AbundOI
  AbundeArray(it, ir, ig)   = Abunde
  AbundHArray(it, ir, ig)   = AbundH
  AbundH2Array(it, ir, ig)  = AbundH2

!!$ dC/dT = cool - dool
!!$ Note: gastemp uses dool to determine convergence of temperature.
!!$ dool is shared in a common block.
  dool = dwat+dco+dhh+fwat+fco+fhh + dCoolGasCII + dCoolGasOI
  if(cooling*deltat.gt.zero) then
!!$ agas = alpha_gas for C proportional to T^alpha_gas
     agas = (tg0/cooling)*(dool-cooling)/deltat
  else
     agas = one
  endif
  if(badnum(cooling).or.(cooling.lt.zero) &
       .or.badnum(agas).or.(agas.lt.zero)) then
     print '(3i4,1p,10e9.2)', &
          it,ir,ig,tg0,dg0,cwat,cco,chh,ewat,eco,ehh,CoolGasCII,CoolGasOI,cooling
     stop
  endif

  return
end function cooling



subroutine ggavg(nul,ntsm,nrsm)
  !	divide gg by gn to get mean intensity

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  dimension ggsm(mu,mt),gnsm(mt)
  logical doprint,even
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)

  doprint = (myrank.eq.0)
  nr2 = nr/2

  if(ntsm.gt.1) then
     nsm2 = (ntsm-1)/2
     even = (nsm2.ne.(ntsm/2))
     !	include angular smoothing in grid 9, but theta_sm will be smaller
     do igr = 0,ng
        !	do only 2 point smooth in grids 1-8
        if(igr.gt.0) then
           nsm2 = 0
           even = .true.
        endif
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        xlr = lr
        do ir = 1,lr
           do it = 1,lt
              jt1 = it-nsm2
              jt2 = it+nsm2
              gnsm(it) = zero
              do iu = 1,nul
                 ggsm(iu,it) = zero
              enddo
              do jt = jt1,jt2
                 if(jt.lt.1) then
                    kt = 1
                 elseif(jt.gt.nt) then
                    kt = 2*nt-jt+1
                 elseif(jt.gt.lt) then
                    kt = lt
                 else
                    kt = jt
                 endif
                 gnsm(it) = gnsm(it)+gn(kt,ir,ig)
                 do iu = 1,nul
                    ggsm(iu,it) = ggsm(iu,it)+gg(iu,kt,ir,ig)
                 enddo
              enddo
              if(even) then
                 jt1 = jt1-1
                 jt2 = jt2+1
                 if(jt1.lt.1) then
                    jt1 = 1
                 elseif(jt2.gt.nt) then
                    jt2 = 2*nt-jt2+1
                 elseif(jt2.gt.lt) then
                    jt2 = lt
                 endif
                 gnsm(it) = gnsm(it)+(gn(jt1,ir,ig)+gn(jt2,ir,ig))/two
                 do iu = 1,nul
                    ggsm(iu,it) = ggsm(iu,it) &
                         +(gg(iu,jt1,ir,ig)+gg(iu,jt2,ir,ig))/two
                 enddo
              endif
           enddo  !  it
           rrat = (xlr/ir)**2
           do it = 1,lt
              gn(it,ir,ig) = rrat*gnsm(it)
              do iu = 1,nul
                 gg(iu,it,ir,ig) = rrat*ggsm(iu,it)
              enddo
           enddo  !  it
        enddo  !  ir
     enddo  !  igr
  endif

  !	smooth mean intensities radially 2 points
  if(nrsm.gt.1) then
     xn9 = two/(one+two*nn9)
     kr2 = nr/2+1
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        kr = max(kr,2)
        do it = 1,lt
           it1 = nt-(nt-it)/nn9
           do iu = 1,nul
              ggj = gg(iu,it,kr-1,ig)
              ggk = gg(iu,it,kr,ig)
              do ir = kr,lr-1
                 ggi = ggj
                 ggj = ggk
                 ggk = gg(iu,it,ir+1,ig)
                 gg(iu,it,ir,ig) = (ggi+two*ggj+ggk)/four
              enddo
              if(ig.lt.ng) then
                 gg(iu,it,lr,ig) = ((ggi+ggj)/two+two*ggk &
                      +gg(iu,it,kr2,ig+1))/four
              elseif(ig.eq.ng9) then
                 ggi = gg(iu,it1,kr2,2)
                 gg(iu,it,lr,ig) = (ggj+(3.-xn9)*ggk+xn9*ggi)/four
              endif
           enddo
           gnj = gn(it,kr-1,ig)
           gnk = gn(it,kr,ig)
           do ir = kr,lr-1
              gni = gnj
              gnj = gnk
              gnk = gn(it,ir+1,ig)
              gn(it,ir,ig) = (gni+two*gnj+gnk)/four
           enddo
           if(ig.lt.ng) then
              gn(it,lr,ig) = ((gni+gnj)/two+two*gnk &
                   +gn(it,kr2,ig+1))/four
           elseif(ig.eq.ng9) then
              gni = gn(it1,kr2,2)
              gn(it,lr,ig) = (gnj+(3.-xn9)*gnk+xn9*gni)/four
           endif
        enddo  !  it
     enddo  !  igr
  endif

  !	divide gg by gn
  gnmin = 1.0d+12
  gnmax = zero
  gnsum = zero
  sumi = zero
  nzero = 0
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     ls = nt-lt+1
     do ir = kr,lr
        r = dr*(ir-half)
        do it = 1,lt
           gni = gn(it,ir,ig)
           if(gni.eq.zero) then
              if((r.gt.rstar).and.(opl(1,it,ir,ig).gt.zero)) then
                 if(doprint.and.(nzero.eq.0)) &
                      print'("Warning: no rays pass through ig,ir,it =", &
                      3i6)', ig,ir,it
                 nzero = nzero+1
              endif
           elseif((ir.gt.lr/2).and.(it.gt.(nt/2))) then
              if(gni.lt.gnmin) then
                 gnmin = gni
                 itmin = it
                 irmin = ir
                 igmin = ig
              elseif(gni.gt.gnmax) then
                 gnmax = gni
                 itmax = it
                 irmax = ir
                 igmax = ig
              endif
              gnsum = gnsum+gni
              sumi = sumi+one
           endif
           if(gni.gt.zero) then
              do iu = 1,nul
                 gg(iu,it,ir,ig) = gg(iu,it,ir,ig)/gni
              enddo
           elseif(ir.gt.kr) then
              do iu = 1,nul
                 gg(iu,it,ir,ig) = gg(iu,it,ir-1,ig)
              enddo
           else
              do iu = 1,nul
                 gg(iu,it,ir,ig) = zero
              enddo
           endif
        enddo  !  it
     enddo  !  ir
  enddo  !  igr
  gnmean = gnsum/sumi
  if(gnmin.gt.gnmax) gnmin = zero
  if(doprint.and.(nal.eq.na)) then
     print '(" min,max,mean rays per cell:",1p,3f12.2)', &
          gnmin,gnmax,gnmean
     print '(6i8)', itmin,irmin,igmin,itmax,irmax,igmax
     if(nzero.gt.0) &
          print '(" no rays pass through",i8," cells of",i8)', &
          nzero,nt*nr2*(ng-1)+nt*nr9
  endif

  return
end subroutine ggavg



subroutine initju(ju,kk)
  !	initialize variables dependent on ju

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /xj/ xju,xjp,xjq,xjr,xk
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  parameter (half = 0.5d+00)
  parameter (two = 2.0d+00)

  if(moltype.eq.3) then
     !	for NH3
     if(mod(kk,3).eq.0) then
        gnucl = 2.
     else
        gnucl = 1.
     endif
  elseif(moltype.eq.4) then
     !	for C2H2 v4+v5
     if(mod(ju,2).eq.0) then
        gnucl = 0.5
     else
        gnucl = 1.5
     endif
  elseif(moltype.eq.5) then
     !	for C2H2 P+R
     !	opacities can be corrected to 2-gnucl for Q in step.  or not
     if(mod(ju,2).eq.0) then
        gnucl = 1.5
     else
        gnucl = 0.5
     endif
  else
     gnucl = 1.
  endif
  jp = ju+1
  jq = ju
  jr = ju-1
  xju = ju
  xjp = jp
  xjq = jq
  xjr = jr
  xk = kk
  wp0 = we-two*xjp*be-ae*xjp**2
  wq0 = we-ae*xju**2
  wr0 = we+two*xju*be-ae*xju**2
  wl(1) = wp0
  wl(2) = wq0
  wl(3) = wr0
  wl(4) = wq0
  nl1 = nl+1
  !	initialize dust sfun, opac, molec densities
  !	interpolate from swd and opa
  do il = 1,nl1
     wi = wl(il)
     !	w = w0*10.**(dlogw*iu)
     ui = slog(wi/wd(1))/log(wd(2)/wd(1))+1.
     iu1 = ui-1.
     iu2 = iu1+1
     iu3 = iu1+2
     iu4 = iu1+3
     if((iu1.lt.1).or.(iu4.gt.nu)) then
        print '(" for line",i3," iu =",2i4)', il,iu1,iu4
        stop
     endif
     du1 = ui-iu1
     du2 = ui-iu2
     du3 = ui-iu3
     du4 = ui-iu4
     wt1 = -du2*du3*du4/6.
     wt2 = du1*du3*du4/2.
     wt3 = -du1*du2*du4/2.
     wt4 = du1*du2*du3/6.
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = 1,lr
           do it = 1,lt
              sw1 = slog(swd(iu1,it,ir,ig))
              sw2 = slog(swd(iu2,it,ir,ig))
              sw3 = slog(swd(iu3,it,ir,ig))
              sw4 = slog(swd(iu4,it,ir,ig))
              swi = sw1*wt1+sw2*wt2+sw3*wt3+sw4*wt4
              sl(il,it,ir,ig) = sexp(swi)
              !                gg(il,it,ir,ig) = sl(il,it,ir,ig)
              op1 = opa(iu1,it,ir,ig)
              op2 = opa(iu2,it,ir,ig)
              op3 = opa(iu3,it,ir,ig)
              op4 = opa(iu4,it,ir,ig)
              opl(il,it,ir,ig) = op1*wt1+op2*wt2+op3*wt3+op4*wt4
              !	neglect scattering by dust at the line wavelengths
           enddo
        enddo
     enddo
  enddo

  return
end subroutine initju



subroutine popju(rufl,sumdnj)
  !	calculate upper state populations

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  parameter (pi = 3.14159265d+00)
  parameter (zilch = 1.0d-200)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)

  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /xj/ xju,xjp,xjq,xjr,xk
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  dimension ddl(mt,mr,mg)
  logical doprint,badnum,docheck
  dimension rufl(mt,mr,mg)

  save dden
  save ipow
  gj(xj) = two*xj+one

  fpi = 4.0d+00*pi
  doprint = (myrank.eq.0)
  docheck = doprint

  wp0 = we-two*xjp*be
  wq0 = we
  wr0 = we+two*xju*be
  hcwe = hc*we
  !	leave grat out here.  put in stepl.  or not.

  if(nit.le.1) then
     ipow = 0
     sumdnj = zero
  endif
  ddju = zero
  ddjumn = zero
  ddjumx = zero
  igmx = 0
  irmx = 0
  itmx = 0
  oldsum = sumdnj
  sumdnj = zero
  sumnnj = zero
  corrdnj = zero

  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        do it = 1,lt
           djp = dl(1,it,ir,ig)
           djq = dl(2,it,ir,ig)
           djr = dl(3,it,ir,ig)
           djlte = dl(5,it,ir,ig)
           ggp = gg(1,it,ir,ig)
           ggq = gg(2,it,ir,ig)
           ggr = gg(3,it,ir,ig)
           rufli = rufl(it,ir,ig)
           if((r.gt.rstar).and.(djp.gt.zero)) then
              !	collisional rates s-1 [cm-3]
              rdcoll = dg(it,ir,ig)*gctg(it,ir,ig)
              rucoll = djlte*rdcoll
              if(rucoll.lt.zilch) rucoll = zero
              !	radiative rates s-1 [cm-3]
              if((moltype.eq.1).or.(moltype.eq.4)) then
                 !	diatomic line strengths and C2H2 v4+v5^0
                 rurad = fpi*(sv/hcwe) &
                      *((djp*xjp/gj(xjp))*ggp+(djr*xju/gj(xjr))*ggr) &
                      +rufli*djq
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *((xjp/gj(xju))*ggp+(xju/gj(xju))*ggr)
              elseif(moltype.eq.2) then
                 !	HCN line strengths
                 rurad = fpi*(sv/hcwe) &
                      *(djp*((xjp-one)/gj(xjp))*ggp &
                      +djr*((xju+one)/gj(xjr))*ggr) &
                      +rufli*djq
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-one)/gj(xju))*ggp &
                      +((xju+one)/gj(xju))*ggr)
                 ruradq = fpi*(sv/hcwe)*djq*ggq &
                      +rufli*djq
                 rdradq = acoeff+fpi*(sv/hcwe)*ggq
              elseif(moltype.eq.3) then
                 !	NH3 line strengths
                 rurad = fpi*(sv/hcwe) &
                      *(djp*((xjp-xk*xk/xjp)/gj(xjp))*ggp &
                      +djq*(xk*xk/(xju*(xju+one)))*ggq &
                      +djr*((xju-xk*xk/xju)/gj(xjr))*ggr) &
                      +rufli*djq
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-xk*xk/xjp)/gj(xju))*ggp &
                      +(xk*xk/(xju*(xju+one)))*ggq &
                      +((xju-xk*xk/xju)/gj(xju))*ggr)
              elseif(moltype.eq.5) then
                 !	C2H2 v5 line strengths
                 rurad = fpi*(sv/hcwe) &
                      *(djp*((xjp-one)/gj(xjp))*ggp &
                      +djr*((xju+one)/gj(xjr))*ggr) &
                      +rufli*djq
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-one)/gj(xju))*ggp &
                      +((xju+one)/gj(xju))*ggr)
                 ruradq = fpi*(sv/hcwe)*djq*ggq &
                      +rufli*djq
                 rdradq = acoeff+fpi*(sv/hcwe)*ggq
              else
                 print '("Unknown moltype")'
                 stop
              endif
              !	v = 1,J=ju population
              if(rurad.lt.zilch) rurad = zero
              if((rdcoll+rdrad).gt.zero) then
                 dju = (rucoll+rurad)/(rdcoll+rdrad)
                 if(dju.lt.zilch) dju = zero
              else
                 print '(" At ",3i4," rdcoll = ",1p,4e10.2)', &
                      it,ir,ig,rdcoll,rdrad,dg(it,ir,ig),gctg(it,ir,ig)
                 stop
              endif
              if(docheck.and.(dju/gj(xju).gt.djp/gj(xjp))) then
                 !	population inversion
                 print '("Warning: population inversion at",3i6)', &
                      it,ir,ig
                 print '(" nj =",1p,6e10.2)', &
                      (dl(il,it,ir,ig),il=1,5),dju
                 print '(" Jnu =",1p,6e10.2)', &
                      (gg(il,it,ir,ig),il=1,3),gg(nu/2+9,it,ir,ig), &
                      bw(wq0,tg(it,ir,ig)),bw(wq0,td(it,ir,ig))
                 docheck = .false.
              endif
              if((ipow.gt.0).and.(dju*dl(4,it,ir,ig).gt.zero)) then
                 dju = dju*(abs(dju/dl(4,it,ir,ig)))**ipow
              elseif((ipow.lt.0).and.(dju*dl(4,it,ir,ig).gt.zero)) then
                 dju = (dju+dl(4,it,ir,ig))/two
              endif
              if(badnum(dju)) then
                 if(doprint) &
                      print '("Warning: at",3i6," dnju =",e10.2)', &
                      it,ir,ig,dju
                 dju = zero
                 ddju = zero
              elseif(dju.gt.zero) then
                 ddju = (dju-dl(4,it,ir,ig))/(dju+dl(4,it,ir,ig))
              else
                 dju = zero
                 ddju = zero
              endif
              if(badnum(ddju)) then
                 if(doprint) &
                      print '("Warning: at",3i6," dnju/nju =",e10.2)', &
                      it,ir,ig,ddju
                 ddju = zero
              elseif(ddju.gt.ddjumx) then
                 ddjumx = ddju
                 if(ddju.gt.(-ddjumn)) then
                    igmx = ig
                    irmx = ir
                    itmx = it
                 endif
              elseif(ddju.lt.ddjumn) then
                 ddjumn = ddju
                 if(ddju.lt.(-ddjumx)) then
                    igmx = ig
                    irmx = ir
                    itmx = it
                 endif
              endif
              sumdnj = sumdnj+ddju**2
              sumnnj = sumnnj+one
              if(nit.gt.1) corrdnj = corrdnj+ddju*ddl(it,ir,ig)
              dl(4,it,ir,ig) = dju

              if((moltype.eq.2).or.(moltype.eq.5)) then
                 !	HCN, C2H2 v = 1e,J=ju population, for Q-branch xitions
                 rurad = ruradq
                 rdrad = rdradq
                 if(rurad.lt.zilch) rurad = zero
                 if(zero*rurad*rdrad.ne.zero) then
                    print '(" ruradq,rdradq =",3e10.2,3i4)', &
                         ruradq,rdradq,gg(2,it,ir,ig),it,ir,ig
                    stop
                 endif
                 if((rdcoll+rdrad).gt.zero) then
                    dju = (rucoll+rurad)/(rdcoll+rdrad)
                    if(dju.lt.zilch) dju = zero
                 else
                    print '(" At ",3i4," rdcoll, rdradq = ",1p,4e10.2)', &
                         it,ir,ig,rdcoll,rdrad,dg(it,ir,ig),acoeff
                    stop
                 endif
                 if((ipow.gt.0).and.(dju*dl(7,it,ir,ig).gt.zero)) then
                    dju = dju*(dju/dl(7,it,ir,ig))**ipow
                 elseif((ipow.lt.0).and.(dl(7,it,ir,ig).gt.zero)) then
                    dju = (dju+dl(7,it,ir,ig))/two
                 endif
                 dl(7,it,ir,ig) = dju
              endif
           else
              ddju = zero
              dl(4,it,ir,ig) = dl(5,it,ir,ig)
              dl(7,it,ir,ig) = dl(5,it,ir,ig)
           endif
           ddl(it,ir,ig) = ddju
        enddo  !  it
     enddo  !  ir
  enddo  !  ig

  if(nit.gt.0) then
     if(doprint) then
        print '(" avg(dnju/nju)^2: ",1p,e10.3)', &
             sumdnj/sumnnj
        print '(" max(dnju/nju): ",1p,2e11.3)', ddjumx,ddjumn
        print '(" worst at:",3i6)', itmx,irmx,igmx
        print '(" corr(dnju/nju): ",1p,e10.3)', &
             corrdnj/(nt*nr*ng)
     endif
     if(corrdnj.lt.zero) then
        if(doprint) print'(" correlation negative.", &
             "  reduce next correction by 2")'
        ipow = -1
     elseif((mod(nit,4).ne.0) &
          .or.(sumdnj*oldsum.eq.zero).or.(sumdnj.gt.oldsum)) then
        ipow = 0
     elseif((corrdnj**2/(sumdnj*oldsum).gt.(0.95)) &
          .and.((sumdnj/oldsum).gt.(0.8))) then
        if(doprint) print '(" amplify next correction by 5")'
        ipow = 4
     elseif((corrdnj**2/(sumdnj*oldsum).gt.(0.9)) &
          .and.((sumdnj/oldsum).gt.(0.7))) then
        if(doprint) print '(" amplify next correction by 4")'
        ipow = 3
     elseif((corrdnj**2/(sumdnj*oldsum).gt.(0.85)) &
          .and.((sumdnj/oldsum).gt.(0.6))) then
        if(doprint) print '(" amplify next correction by 3")'
        ipow = 2
     elseif((corrdnj**2/(sumdnj*oldsum).gt.(0.8)) &
          .and.((sumdnj/oldsum).gt.(0.5))) then
        if(doprint) print '(" amplify next correction by 2")'
        ipow = 1
     else
        ipow = 0
     endif
  endif
  sumdnj = sumdnj/sumnnj
  !	calculate population of v = 2 level: dl(6)
  !	approximate with optically thin Q branch line
  !	wrong for C2H2 and HCN?
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        do it = 1,lt
           if((r.gt.rstar).and.(dg(it,ir,ig).gt.zero)) then
              !	downward collisional rate s-1
              rdcoll = dg(it,ir,ig)*gctg(it,ir,ig)
              !	upward collisional rate s-1 cm-3
              rucoll = rdcoll*dl(4,it,ir,ig) &
                   *(dl(5,it,ir,ig)/dl(2,it,ir,ig))
              if(badnum(rucoll).or.(rucoll.lt.zilch)) rucoll = zero
              !	downward radiative rate, spontaneous+stimulated s-1
              !	diatomic rates
              rdrad = acoeff+fpi*(sv/hcwe)*gg(4,it,ir,ig)
              !	upward radiative rate s-1 cm-3
              !	diatomic line strengths work for all non-degenerate states?
              !	note: gg(4) is continuum
              rurad = fpi*(sv/hcwe)*dl(4,it,ir,ig)*gg(4,it,ir,ig) &
                   +rufl(it,ir,ig)*dl(4,it,ir,ig)
              !	I don''t know what to do for C2H2 with degenerate modes
              if(rurad.lt.zilch) rurad = zero
              !	v=2, J=jq population
              if((rdcoll+rdrad).gt.zero) then
                 dju = (rucoll+rurad)/(rdcoll+rdrad)
                 if(dju.lt.zilch) dju = zero
              else
                 dju = zero
              endif
              dl(6,it,ir,ig) = dju
           else
              dl(6,it,ir,ig) = zero
           endif
        enddo  !  it
     enddo  !  ir
  enddo  !  ig

  !	calculate population of isotopic v = 1 level: dl(8)
  !	assume optically thin lines
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        do it = 1,lt
           if((r.gt.rstar).and.(dg(it,ir,ig).gt.zero)) then
              !	downward collisional rate s-1
              rdcoll = dg(it,ir,ig)*gctg(it,ir,ig)
              !	upward collisional rate s-1 cm-3
              rucoll = rdcoll*popiso*dl(5,it,ir,ig)
              if(rucoll.lt.zilch) rucoll = zero
              if((moltype.eq.1).or.(moltype.eq.4)) then
                 !	diatomic line strengths and C2H2 v4+v5^0
                 rurad = fpi*(sv/hcwe)*popiso &
                      *(dl(1,it,ir,ig)*(xjp/(gj(xjp)))*gg(4,it,ir,ig) &
                      +dl(3,it,ir,ig)*(xju/(gj(xjr)))*gg(4,it,ir,ig)) &
                      +rufl(it,ir,ig)*dl(2,it,ir,ig)*popiso
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *((xjp/(gj(xju)))*gg(4,it,ir,ig) &
                      +(xju/(gj(xju)))*gg(4,it,ir,ig))
              elseif(moltype.eq.2) then
                 !	HCN line strengths
                 rurad = fpi*(sv/hcwe)*popiso &
                      *(dl(1,it,ir,ig)*((xjp-one)/(gj(xjp)))*gg(4,it,ir,ig) &
                      +dl(3,it,ir,ig)*((xju+one)/(gj(xjr)))*gg(4,it,ir,ig)) &
                      +rufl(it,ir,ig)*dl(2,it,ir,ig)*popiso
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-one)/(gj(xju)))*gg(4,it,ir,ig) &
                      +((xju+one)/(gj(xju)))*gg(4,it,ir,ig))
                 ruradq = fpi*(sv/hcwe)*popiso &
                      *dl(2,it,ir,ig)*gg(4,it,ir,ig)
                 rdradq = acoeff+fpi*(sv/hcwe)*gg(4,it,ir,ig)
              elseif(moltype.eq.3) then
                 !	NH3 line strengths
                 rurad = fpi*(sv/hcwe)*popiso &
                      *(dl(1,it,ir,ig)*((xjp-xk*xk/xjp)/(gj(xjp)))*gg(4,it,ir,ig) &
                      +dl(2,it,ir,ig)*(xk*xk/(xju*(xju+one)))*gg(4,it,ir,ig) &
                      +dl(3,it,ir,ig)*((xju-xk*xk/xju)/(gj(xjr)))*gg(4,it,ir,ig)) &
                      +rufl(it,ir,ig)*dl(2,it,ir,ig)*popiso
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-xk*xk/xjp)/(gj(xju)))*gg(4,it,ir,ig) &
                      +(xk*xk/(xju*(xju+one)))*gg(4,it,ir,ig) &
                      +((xju-xk*xk/xju)/(gj(xju)))*gg(4,it,ir,ig))
              elseif(moltype.eq.5) then
                 !	C2H2 v5 line strengths
                 rurad = fpi*(sv/hcwe)*popiso &
                      *(dl(1,it,ir,ig)*((xjp-one)/(gj(xjp)))*gg(4,it,ir,ig) &
                      +dl(3,it,ir,ig)*((xju+one)/(gj(xjr)))*gg(4,it,ir,ig))
                 rdrad = acoeff+fpi*(sv/hcwe) &
                      *(((xjp-one)/(gj(xju)))*gg(4,it,ir,ig) &
                      +((xju+one)/(gj(xju)))*gg(4,it,ir,ig))
                 ruradq = fpi*(sv/hcwe)*popiso &
                      *dl(2,it,ir,ig)*gg(2,it,ir,ig) &
                      +rufl(it,ir,ig)*dl(2,it,ir,ig)*popiso
                 rdradq = acoeff+fpi*(sv/hcwe)*gg(4,it,ir,ig)
              else
                 print '("Unknown moltype")'
                 stop
              endif
              !	v = 1,J=ju population
              if(rurad.lt.zilch) rurad = zero
              if(zero*rurad*rdrad.ne.zero) then
                 print '(" rurad,rdrad =",3e10.2,3i4)', &
                      rurad,rdrad,gg(1,it,ir,ig),ig,ir,it
                 stop
              endif
              if((rdcoll+rdrad).gt.zero) then
                 dju = (rucoll+rurad)/(rdcoll+rdrad)
                 if(dju.lt.zilch) dju = zero
              else
                 dju = zero
              endif
              dl(8,it,ir,ig) = dju
           else
              dl(8,it,ir,ig) = dl(5,it,ir,ig)
           endif
        enddo  !  it
     enddo  !  ir
  enddo  !  ig

  !	copy grid 9 to grid 1 and fill in inner halves
  ig = 1
  jg = ng9
  xn9 = nn9**2
  nn8 = nn9-1
  nt8 = nt-nt/nn9
  do ir = 1,nr
     jr2 = nn9*ir
     jr1 = jr2-nn9+1
     do kt = 1,nt/nn9
        it = kt+nt8
        dl(4,it,ir,ig) = zero
        dl(6,it,ir,ig) = zero
        dl(7,it,ir,ig) = zero
        dl(8,it,ir,ig) = zero
        jt1 = kt*nn9
        jt0 = jt1-nn9+1
        do jr = jr1,jr2
           do jt = jt0,jt1
              dl(4,it,ir,ig) = dl(4,it,ir,ig)+dl(4,jt,jr,jg)/xn9
              dl(6,it,ir,ig) = dl(6,it,ir,ig)+dl(6,jt,jr,jg)/xn9
              dl(7,it,ir,ig) = dl(7,it,ir,ig)+dl(7,jt,jr,jg)/xn9
              dl(8,it,ir,ig) = dl(8,it,ir,ig)+dl(8,jt,jr,jg)/xn9
           enddo
        enddo
     enddo
  enddo
  do ig = 2,ng
     jg = ig-1
     do ir = 1,nr/2
        ir2 = 2*ir
        ir1 = ir2-1
        do it = 1,nt
           dl(4,it,ir,ig) = (dl(4,it,ir1,jg)+dl(4,it,ir2,jg))/two
           dl(6,it,ir,ig) = (dl(6,it,ir1,jg)+dl(6,it,ir2,jg))/two
           dl(7,it,ir,ig) = (dl(7,it,ir1,jg)+dl(7,it,ir2,jg))/two
           dl(8,it,ir,ig) = (dl(8,it,ir1,jg)+dl(8,it,ir2,jg))/two
        enddo
     enddo
  enddo

  return
end subroutine popju



subroutine grid0(fwk,ly)
  !	step through outermost grid and call next grid in

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwk(mw,ml)
  dimension fwi(mw,ml)
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /angls/ dcost,dcos9,rot,irot
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  !	first grid to calculate
  ig = ng
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  !	zero spectrum summed over lines of sight
  do il = 1,ll
     do iw = 1,lw
        fwk(iw,il) = zero
     enddo
  enddo
  do ix = 1,nx
     do iy = 1,ly
        taucont = zero
        tauline = zero
        tauterm = zero
        !	in middle 1/2 x 1/2 of grid?
        middle = (ix.gt.nx4).and.(ix.le.nx3) &
             .and.(iy.gt.nx4).and.(iy.le.nx3)
        if(middle) then
           !	use finer grid for grid section above and below middle
           jx2 = 2*ix-nx2
           jx1 = jx2-1
           jy2 = 2*iy-nx2
           jy1 = jy2-1
           do jx = jx1,jx2
              do jy = jy1,jy2
                 taucont = zero
                 tauline = zero
                 tauterm = zero
                 !	zero spectrum for line of sight
                 do il = 1,ll
                    do iw = 1,lw
                       fwi(iw,il) = zero
                    enddo
                 enddo
                 iz = 0
                 !	should this be vterm?
                 wdopp = zero
                 !	step along line of sight
14               iz = iz+1
                 if(iz.eq.nz5) then
                    if(ig.eq.12) then
                       call gridb(fwi,jx,jy,wdopp)
                    elseif(ig.eq.11) then
                       call grida(fwi,jx,jy,wdopp)
                    elseif(ig.eq.10) then
                       call grid9(fwi,jx,jy,wdopp)
                    elseif(ig.eq.9) then
                       call grid8(fwi,jx,jy,wdopp)
                    elseif(ig.eq.8) then
                       call grid7(fwi,jx,jy,wdopp)
                    elseif(ig.eq.7) then
                       call grid6(fwi,jx,jy,wdopp)
                    elseif(ig.eq.6) then
                       call grid5(fwi,jx,jy,wdopp)
                    elseif(ig.eq.5) then
                       call grid4(fwi,jx,jy,wdopp)
                    elseif(ig.eq.4) then
                       call grid3(fwi,jx,jy,wdopp)
                    elseif(ig.eq.3) then
                       call grid2(fwi,jx,jy,wdopp)
                    else
                       print '(" ng =",i4,"?")', ig
                       stop
                    endif
                    iz = iz+nz/2
                 endif
                 !	call radiative transfer routine for step
                 call step(fwi,wdopp,jx,jy,iz,-ig)
                 !	end loop along line of sight
                 if(iz.lt.nz) go to 14
                 !	store compressed spectrum in data cube
                 if(ig.le.ngc) call storecube(fwi,jg,jx,jy)
                 !	add outgoing spectrum to sum from grid
                 do il = 1,ll
                    do iw = 1,lw
                       fwk(iw,il) = fwk(iw,il)+fwi(iw,il)/4.
                    enddo
                 enddo
                 !	end loops over 4 lines of sight
              enddo
           enddo
        else
           !	not in middle.  follow ray along ix,iy
           do il = 1,ll
              do iw = 1,lw
                 fwi(iw,il) = zero
              enddo
           enddo
           !	and this?
           wdopp = zero
           !	step along line of sight
           do iz = 1,nz
              !	call radiative transfer routine for step
              call step(fwi,wdopp,ix,iy,iz,ig)
           enddo
           !	store compressed spectrum in data cube
           if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
           !	add outgoing spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwi(iw,il)
              enddo
           enddo
        endif
        !	end loops over lines of sight in ix,iy grid
     enddo
  enddo

  return
end subroutine grid0


subroutine gridb(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 11
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grida(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine gridb


subroutine grida(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 10
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid9(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grida


subroutine grid9(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 9
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid8(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid9


subroutine grid8(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 8
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid7(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid8


subroutine grid7(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 7
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid6(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid7


subroutine grid6(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 6
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid5(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid6


subroutine grid5(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 5
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid4(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid5


subroutine grid4(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 4
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid3(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        !	call radiative transfer routine for step
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid4


subroutine grid3(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 3
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid2(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        !	call radiative transfer routine for step
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid3


subroutine grid2(fwi,ix,iy,wdopp0)

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  ig = 2
  jg = ig-1
  nx2 = nx/2
  nx4 = nx/4
  nx3 = 3*nx4
  nz5 = nz/4+1

  middle = (ix.gt.nx4).and.(ix.le.nx3) &
       .and.(iy.gt.nx4).and.(iy.le.nx3)
  if(middle) then
     do il = 1,ll
        do iw = 1,lw
           fwk(iw,il) = zero
        enddo
     enddo
     !	branch out by 2x2
     jx2 = 2*ix-nx2
     jx1 = jx2-1
     jy2 = 2*iy-nx2
     jy1 = jy2-1
     do jx = jx1,jx2
        do jy = jy1,jy2
           !	copy spectrum from outer grid
           do il = 1,ll
              do iw = 1,lw
                 fwj(iw,il) = fwi(iw,il)
              enddo
           enddo
           wdopp = wdopp0
           !	step along line of sight
           iz = 0
24         iz = iz+1
           if(iz.eq.nz5) then
              call grid1(fwj,jx,jy,wdopp)
              iz = iz+nz/2
           endif
           !	call radiative transfer routine for step
           call step(fwj,wdopp,jx,jy,iz,-ig)
           !	end loop along line of sight
           if(iz.lt.nz) go to 24
           !	store compressed spectrum in data cube
           if(ig.le.ngc) call storecube(fwj,jg,jx,jy)
           !	add spectrum to sum from grid
           do il = 1,ll
              do iw = 1,lw
                 fwk(iw,il) = fwk(iw,il)+fwj(iw,il)/4.
              enddo
           enddo
           !	end loops over 4 lines of sight
        enddo
     enddo
     do il = 1,ll
        do iw = 1,lw
           fwi(iw,il) = fwk(iw,il)
        enddo
     enddo
  else
     !	not in the middle, don''t branch out
     wdopp = wdopp0
     !	step along line of sight
     do iz = 1,nz
        !	call radiative transfer routine for step
        call step(fwi,wdopp,ix,iy,iz,ig)
     enddo
     !	store compressed spectrum in data cube
     if(ig.eq.ngc) call storecube(fwi,ig,ix,iy)
  endif
  wdopp0 = wdopp

  return
end subroutine grid2


subroutine grid1(fwi,ix,iy,wdopp0)
  !	step along ray in innermost (expanded) grid

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mu = 64)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (au = 1.496d+13)
  dimension fwi(mw,ml)
  dimension fwj(mw,ml),fwk(mw,ml)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /cube/ cube(mc,mc,mc),ngc
  logical middle,doprint

  ig = ng9
  !	middle is not a special case for grid 1
  !	store expanded dust grid to cube(,,,2)
  if((irot.eq.1).and.(ix.eq.nx/2)) then
     taucont = zero
     tauline = zero
  endif

  do il = 1,ll
     do iw = 1,lw
        fwk(iw,il) = zero
     enddo
  enddo
  !	branch out by nn9*nn9
  jx1 = nn9*(ix-1)+1
  jx2 = nn9*ix
  jy1 = nn9*(iy-1)+1
  jy2 = nn9*iy
  do jx = jx1,jx2
     do jy = jy1,jy2
        !	copy spectrum from outer grid
        do il = 1,ll
           do iw = 1,lw
              fwj(iw,il) = fwi(iw,il)
           enddo
        enddo
        wdopp = wdopp0
        !	step along line of sight
        do iz = 1,nz9
           call step(fwj,wdopp,jx,jy,iz,ig)
        enddo
        !	store compressed dust spectrum in data cube
        if(moltype.le.0) call storecube(fwj,ig,jx,jy)
        !	add spectrum to sum from grid
        do il = 1,ll
           do iw = 1,lw
              fwk(iw,il) = fwk(iw,il)+fwj(iw,il)
           enddo
        enddo
        !	end loops over lines of sight on grid
     enddo
  enddo
  !	print optical depths
  if((irot.eq.1).and.(nit.eq.1).and.(ix.eq.nx/2) &
       .and.((taucont+tauline).gt.zero)) then
     y = (ny-2*iy+1)*dx0
     print '(" at y =",f7.2, &
          " continuum, line taus =",1p,2e10.2)', &
          y/au,taucont,tauline
  endif
  !	put sum from grid into fwi
  xn9 = nn9**2
  do il = 1,ll
     do iw = 1,lw
        fwi(iw,il) = fwk(iw,il)/xn9
     enddo
  enddo
  wdopp0 = wdopp

  return
end subroutine grid1



subroutine storecube(fwi,ig,ix,iy)
  !	store compressed spectrum in data cube

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  parameter (ml = 8)
  parameter (mc = 256)
  dimension fwi(mw,ml)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /cube/ cube(mc,mc,mc),ngc
  logical middle

  nx3 = 3*nx/4
  nx4 = nx/4
  if(ig.eq.ng9) then
     if(moltype.gt.0) return
     nc = mc
     if(nc.ge.nx9) then
        ncnx = nc/nx9
        kx4 = ncnx*ix
        kx3 = kx4-ncnx+1
        ky4 = ncnx*iy
        ky3 = ky4-ncnx+1
        if((kx3.lt.1).or.(kx4.gt.mc).or.(ky3.lt.1).or.(ky4.gt.mc)) then
           print '(" in storecube kx3,kx4,ky3,ky4 =",5i8)', &
                kx3,kx4,ky3,ky4,mc
           return
        endif
        fwisil = fwi(iusil,1)
        do ky = ky3,ky4
           ky1 = nc+1-ky
           do kx = kx3,kx4
              cube(kx,ky,2) = fwisil
              cube(kx,ky1,2) = fwisil
           enddo
        enddo
     else
        ncnx = nx9/nc
        kx = (ix+1)/ncnx
        ky = (iy+1)/ncnx
        if((kx.lt.1).or.(kx.gt.nc).or.(ky.lt.1).or.(ky.gt.nc)) then
           print '(" in storecube kx3,kx4,ky3,ky4 =",5i8)', &
                kx3,kx4,ky3,ky4,nc
           return
        endif
        fwisil = fwi(iusil,1)/ncnx
        ky1 = nc+1-ky
        if((mod(ix,ncnx).eq.1).and.(mod(iy,ncnx).eq.1)) then
           cube(kx,ky,2) = fwisil
           cube(kx,ky1,2) = fwisil
        else
           cube(kx,ky,2) = cube(kx,ky,2)+fwisil
           cube(kx,ky1,2) = cube(kx,ky1,2)+fwisil
        endif
     endif
  elseif(ig.gt.ngc) then
     return
  else
     nc = mc/2**(ngc-ig)
     ncnx = nc/nx
     middle = (ix.gt.nx4).and.(ix.le.nx3) &
          .and.(iy.gt.nx4).and.(iy.le.nx3)
     if((middle.and.(ncnx.gt.1).and.(ig.gt.1)) &
          .or.(ncnx.lt.1)) return
     kx4 = ncnx*ix+(mc-nc)/2
     kx3 = kx4-ncnx+1
     ky4 = ncnx*iy+(mc-nc)/2
     ky3 = ky4-ncnx+1
     if((kx3.lt.1).or.(kx4.gt.mc).or.(ky3.lt.1).or.(ky4.gt.mc)) then
        print '(" in storecube kx3,kx4,ky3,ky4 =",5i8)', &
             kx3,kx4,ky3,ky4,mc
        stop
     endif
     if(moltype.gt.0) then
        nnw = 2*nw/mc
        xnw = nnw
        iwp = 1
        iwr = 1+mc/2
        do ky = ky3,ky4
           ky1 = mc+1-ky
           do kx = kx3,kx4
              cube(kx,ky,iwp) = fwi(1,1)
              cube(kx,ky,iwr) = fwi(1,3)
              if(ky.le.mc/2) then
                 cube(kx,ky1,iwp) = fwi(1,1)
                 cube(kx,ky1,iwr) = fwi(1,3)
              endif
           enddo
        enddo
        do iw0 = nnw,nw-nnw,nnw
           iwp = iw0/nnw+1
           iwr = iwp+mc/2
           fwpii = zero
           fwpij = zero
           fwrii = zero
           fwrij = zero
           do iw = iw0+1,iw0+nnw
              iw1 = nw+1-iw
              fwpii = fwpii+fwi(iw,1)
              fwpij = fwpij+fwi(iw1,1)
              fwrii = fwrii+fwi(iw,3)
              fwrij = fwrij+fwi(iw1,3)
           enddo
           do ky = ky3,ky4
              ky1 = mc+1-ky
              do kx = kx3,kx4
                 cube(kx,ky,iwp) = fwpii/xnw
                 cube(kx,ky,iwr) = fwrii/xnw
                 if(ky.le.mc/2) then
                    cube(kx,ky1,iwp) = fwpij/xnw
                    cube(kx,ky1,iwr) = fwrij/xnw
                 endif
              enddo
           enddo
        enddo
     else
        fwisil = fwi(iusil,1)
        do ky = ky3,ky4
           ky1 = mc+1-ky
           do kx = kx3,kx4
              cube(kx,ky,1) = fwisil
              cube(kx,ky1,1) = fwisil
           enddo
        enddo
     endif
  endif

  return
end subroutine storecube



subroutine diffr(fwi,it,ir,igr)
  !	radial diffusion to get line radiative transfer started

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /xj/ xju,xjp,xjq,xjr,xk
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /ww/ wr(mt,mr,mg),wth(mt,mr,mg),wph(mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  dimension fwi(mw,ml)
  logical badnum

  parameter (pi = 3.14159265d+00)
  parameter (sqrtpi = 1.772454d+00)
  parameter (sqrt2 = 1.414214d+00)
  parameter (small = 1.0d-03)
  parameter (tiny = 1.0d-08)
  parameter (zilch = 1.0d-200)
  parameter (hun = 1.0d+02)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (half = 0.5d+00)
  parameter (hc2 = 5.955d-06)
  parameter (au = 1.496d+13)

  if((igr.eq.0).or.(igr.eq.ng9)) then
     ig = ng9
     dr = dr9
     dcosth = dcos9
  else
     ig = igr
     dr = dr0*two**igr
     dcosth = dcost
  endif
  r = (ir-half)*dr
  ds = dr
  costh = dcosth*(nt-it+half)
  dens = dg(it,ir,ig)
  dmol = dl(2,it,ir,ig)
  dju = dl(4,it,ir,ig)
  opacd = opl(2,it,ir,ig)
  taud = opacd*ds
  swd = sl(2,it,ir,ig)

  il = 2
  if((ir.eq.1).or.(r.lt.rstar)) then
     gg(il,it,ir,ig) = fwi(2,il)
     return
  elseif(dens.lt.zilch) then
     ostar = (one-sqrt(one-(rstar/r)**2))/two
     gg(il,it,ir,ig) = fwi(2,il)*ostar
     return
  endif

  dwr = wec*sqrt(dvturb0**2+dvturb1**2*au/r)
  dwhwzi = 4.*dwr
  phiint = sqrtpi*dwr
  we3 = we**3
  opfac = dmol*sv
  emfac = two*hc2*we3*sv*dju
  rdcoll = dens*gctg(it,ir,ig)
  absmol = rdcoll/(acoeff+rdcoll)
  !	rough average over line
  taumol = half*opfac*ds/phiint
  tauabs = taumol*absmol
  taueff = sqrt((taud+tauabs)*(taud+taumol))

  taucont = taucont+taud
  tauline = tauline+taumol
  tauefff = tauefff+taueff
  if(taueff.eq.zero) then
     !	this makes radiation stellar inside of inner rim even if molecules
     !	are present.  what is the right answer?
     ostar = (one-sqrt(one-(rstar/r)**2))/two
     !	try turning it off
     ostar = zero
     gg(il,it,ir,ig) = fwi(2,il)*ostar
  else
     emiss = one-sexp(-two*taueff)
     atten = (one-emiss)/(one+taumol)
     gg(il,it,ir,ig) = gg(il,it,ir-1,ig)*atten &
          +sl(il,it,ir,ig)*emiss
     gg(4,it,ir,ig) = swd+(gg(4,it,ir,ig)-swd)*sexp(-taud)
  endif

  return
end subroutine diffr



subroutine diffz(fwi,ix,iy,iz,igr)
  !	axial diffusion to get line radiative transfer started

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /xj/ xju,xjp,xjq,xjr,xk
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /ww/ wr(mt,mr,mg),wth(mt,mr,mg),wph(mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  dimension fwi(mw,ml)
  logical good

  parameter (pi = 3.14159265d+00)
  parameter (sqrtpi = 1.772454d+00)
  parameter (sqrt2 = 1.414214d+00)
  parameter (small = 1.0d-03)
  parameter (tiny = 1.0d-08)
  parameter (zilch = 1.0d-200)
  parameter (hun = 1.0d+02)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (half = 0.5d+00)
  parameter (eighth = 0.125d+00)
  parameter (alog2 = 0.6931472d+00)
  parameter (hc2 = 5.955d-06)
  parameter (au = 1.496d+13)

  jg = abs(igr)
  if((jg.lt.1).or.(jg.gt.ng9)) then
     print '(" in diffz, igr =",i6)', igr
     stop
  elseif((jg.eq.1).or.(jg.eq.ng9)) then
     jg = ng9
     lx = nx9
     dx = dx9
     lz = nz9
     dz = dz9
  else
     twig = two**jg
     lx = nx
     dx = dx0*twig
     lz = nz
     dz = dz0*twig
  endif
  if(igr.lt.0) dx = dx/two
  lx2 = lx/2
  dx2 = dx/two
  dz2 = dz/two
  ds = dz
  x = dx2*(2*ix-lx-1)
  y = dx2*(2*iy-lx-1)
  z = dz2*(2*iz-lz-1)
  r = sqrt(x**2+y**2+z**2)
  !	rot = 0
  crot = cos(rot)
  srot = sin(rot)
  costh = abs(crot*z+srot*x)/r
  sinth = sqrt(one-costh**2)
  ph = atan2(y,(crot*x-srot*z))
  dcosth = dcost
  cosmx = nt*dcos9
  ig = slog(r/(nr*dr0))/alog2+one
  if(jg.le.ng) then
     ig = max(ig,jg)
     if(ig.eq.jg) then
        dr = dr0*twig
        lr = nr
        gwt = one
     elseif((ig.eq.jg+1).and.(ig.le.ng)) then
        dr = two*dr0*twig
        lr = nr
        gwt = eighth
     else
        return
     endif
  else
     ig = max(ig,1)
     if(ig.gt.1) then
        ig = 2
        dr = four*dr0
        lr = nr
        gwt = (dz9/(four*dz0))*(dx9/(four*dx0))**2
     elseif(abs(costh).gt.cosmx) then
        ig = 1
        dr = two*dr0
        lr = nr
        gwt = (dz9/(two*dz0))*(dx9/(two*dx0))**2
     else
        ig = ng9
        dr = dr9
        lr = nr9
        gwt = one
        dcosth = dcos9
     endif
  endif
  ir = r/dr+one
  it = nt-nint(abs(costh)/dcosth-half)
  if((it.lt.1).or.(it.gt.nt)) return
  il = 2

  !	blackbody if on star
  if(r.lt.rstar) then
     taucont = zero
     tauline = zero
     tauterm = zero
     ff(il,it,ir,ig) = fwi(1,il)
     fn(it,ir,ig) = one
     return
  endif

  !	not on star
  dens = dg(it,ir,ig)
  dmol = dl(2,it,ir,ig)
  dju = dl(4,it,ir,ig)
  opacd = opl(2,it,ir,ig)
  taud = opacd*ds
  swd = sl(2,it,ir,ig)

  dwr = sqrt((dvturb0**2+dvturb1**2*au/r)*wec**2+dw**2)
  dwhwzi = 4.*dwr
  phiint = sqrtpi*dwr
  we3 = we**3
  opfac = dmol*sv
  emfac = 2.*hc2*we3*sv*dju
  rdcoll = dens*gctg(it,ir,ig)
  absmol = rdcoll/(acoeff+rdcoll)
  !	rough average over line
  taumol = 0.5*opfac*ds/phiint
  tauabs = taumol*absmol
  taueff = sqrt((taud+tauabs)*(taud+taumol))

  taucont = taucont+taud
  tauline = tauline+taumol
  tauefff = tauefff+taueff
  if(tauefff.eq.zero) then
     !	I don''t think this is right.  Should it have a graz factor?
     ostar = (one-sqrt(one-(rstar/r)**2))/2.
     ff(il,it,ir,ig) = fwi(2,il)*ostar
     fn(it,ir,ig) = one
  else
     emiss = one-sexp(-2.*taueff)
     atten = (one-emiss)/(one+taumol)
     fwi(1,il) = fwi(1,il)*atten+sl(il,it,ir,ig)*emiss
     ff(il,it,ir,ig) = ff(il,it,ir,ig)+gwt*fwi(1,il)
     fwi(1,4) = swd+(fwi(1,4)-swd)*sexp(-taud)
     ff(4,it,ir,ig) = ff(4,it,ir,ig)+gwt*fwi(1,4)
     fn(it,ir,ig) = fn(it,ir,ig)+gwt
  endif

  return
end subroutine diffz



subroutine step(fwi,wdopp0,ix,iy,iz,igr)
  !	call appropriate step routine for dust or line rad xfer

  implicit real*8 (a-h,o-z)
  parameter (ml = 8)
  parameter (mw = 1024)

  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /angls/ dcost,dcos9,rot,irot
  dimension fwi(mw,ml)

  if(moltype.le.0) then
     call stepd(fwi,ix,iy,iz,igr)
  elseif(irot.eq.0) then
     call diffz(fwi,ix,iy,iz,igr)
  else
     call stepl(fwi,wdopp0,ix,iy,iz,igr)
  endif

  return
end subroutine step




subroutine stepl(fwi,wdopp0,ix,iy,iz,igr)
  !	radiative transfer in a molecular line

  implicit real*8 (a-h,o-z)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mg = 20)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)

  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /angls/ dcost,dcos9,rot,irot
  common /xj/ xju,xjp,xjq,xjr,xk
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  common /vels/ wr(mt,mr,mg),wth(mt,mr,mg),wph(mt,mr,mg)
  common /taus/ taucont,tauline,tauterm,iuv,iusil,iufl,iwterm
  common /exptab/ expi(10239),too
  dimension fwi(mw,ml)
  logical good,doprint,docheck,badnum
  save docheck

  parameter (pi = 3.14159265d+00)
  parameter (sqrtpi = 1.772454d+00)
  parameter (sqrt2 = 1.414214d+00)
  parameter (alog2 = 0.6931472d+00)
  parameter (small = 1.0d-03)
  parameter (tiny = 1.0d-08)
  parameter (zilch = 1.0d-200)
  parameter (hun = 1.0d+02)
  parameter (big = 5.0d+03)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (half = 0.5d+00)
  parameter (eighth = 0.125d+00)
  parameter (hc2 = 5.955d-06)
  parameter (au = 1.496d+13)

  doprint = (myrank.eq.0)
  nw2 = nw/2
  dw2 = dw/two
  grat = (two-gnucl)/gnucl
  !	set grat = 1 for a pseudo-line with same gnucl as P,R

  jg = abs(igr)
  if((jg.eq.ng).and.(ix.eq.1).and.(iy.eq.1)) docheck = doprint
  if((jg.eq.1).or.(jg.eq.ng9)) then
     jg = ng9
     lx = nx9
     dx = dx9
     lz = nz9
     dz = dz9
     rmx = nr9*dr9
  else
     twig = two**jg
     lx = nx
     dx = dx0*twig
     lz = nz
     dz = dz0*twig
     rmx = nr*dr0*twig
  endif
  if(igr.lt.0) dx = dx/two
  lx2 = lx/2
  dx2 = dx/two
  dz2 = dz/two
  ds = dz
  x = dx2*(2*ix-lx-1)
  y = dx2*(2*iy-lx-1)
  z = dz2*(2*iz-lz-1)
  r = sqrt(x**2+y**2+z**2)
  crot = cos(rot)
  srot = sin(rot)
  costh = (crot*z+srot*x)/r
  if(abs(costh).gt.(nt*dcost)) return
  sinth = sqrt(one-costh**2)
  dcosth = dcost
  cosmx = nt*dcos9
  ph = atan2(y,(crot*x-srot*z))
  if(jg.le.ng) then
     if(r.le.rmx) then
        ig = jg
        dr = dr0*twig
        lr = nr
        gwt = one
     elseif(jg.lt.ng) then
        ig = jg+1
        dr = two*dr0*twig
        lr = nr
        gwt = eighth
     else
        return
     endif
  else
     if(r.gt.rmx) then
        ig = 2
        dr = four*dr0
        lr = nr
        gwt = (dz9/(four*dz0))*(dx9/(four*dx0))**2
     elseif(abs(costh).gt.cosmx) then
        ig = 1
        dr = two*dr0
        lr = nr
        gwt = (dz9/(two*dz0))*(dx9/(two*dx0))**2
        !	never happens?
        if(igr.eq.1) jg = 1
     else
        ig = ng9
        dr = dr9
        lr = nr9
        !            gwt = (dz9/(two*dz0))*(dx9/(two*dx0))**2
        gwt = one/nn9
        dcosth = dcos9
     endif
  endif
  ir = r/dr+one
  if(igr.lt.0) gwt = gwt/four
  it = nt-nint(abs(costh)/dcosth-half)


  !	does ray hit star?
  if((jg.eq.ng9).and.(z.gt.zero).and.(z.lt.dz)) then
     xi = abs(x)-dx2
     yi = abs(y)-dx2
     ri = sqrt(xi**2+yi**2)
     if(ri.lt.rstar) then
        xo = xi+dx
        yo = yi+dx
        ro = sqrt(xo**2+yo**2)
        if(ro.lt.rstar) then
           astar = one
        elseif((abs(x).lt.dx).and.(abs(y).lt.dx)) then
           if(rstar.lt.dx) then
              astar = (pi/4.)*rstar**2/dx**2
           else
              astar = one-(sqrt2-rstar/dx)**2
           endif
        else
           ri = sqrt(x**2+y**2)-dx2
           ro = ri+dx
           if(ri.gt.rstar) then
              astar = zero
           elseif(ro.lt.rstar) then
              astar = one
           else
              astar = (rstar-ri)/dx
           endif
        endif
        if(astar.gt.zero) then
           do iw = 1,nw
              do il = 1,nl
                 fwi(iw,il) = (one-astar)*fwi(iw,il)+astar*fstar(il)
              enddo
           enddo
           do il = 1,nl
              ff(il,it,ir,ig) = ff(il,it,ir,ig)+gwt*fwi(1,il)
           enddo
           ff(4,it,ir,ig) = ff(4,it,ir,ig)+gwt*fwi(1,2)
           fn(it,ir,ig) = fn(it,ir,ig)+gwt
           return
        endif
     endif
  elseif(r.lt.rstar) then
     do iw = 1,nw
        do il = 1,nl
           fwi(iw,il) = fstar(il)
        enddo
     enddo
     return
  endif

  !	not on star
  wp0 = we-two*xjp*be
  wq0 = we
  wr0 = we+two*xju*be
  spd = sl(1,it,ir,ig)
  sqd = sl(2,it,ir,ig)
  srd = sl(3,it,ir,ig)
  vr = wr(it,ir,ig)
  vth = wth(it,ir,ig)
  vph = wph(it,ir,ig)
  vtot = sqrt(vr**2+vth**2+vph**2)
  vz = vr*z/r+vph*sin(ph)*srot
  if(vth.ne.zero) vz = vz-vth*(sinth*crot+costh*cos(ph)*srot)
  da = dg(it,ir,ig)
  if(da.lt.zilch) then
     dlte = zero
     da = zero
     djp = zero
     djq = zero
     djr = zero
     dju = zero
     dje = zero
     dlte = zero
     rdcoll = zero
  else
     djp = dl(1,it,ir,ig)
     djq = dl(2,it,ir,ig)
     djr = dl(3,it,ir,ig)
     dju = dl(4,it,ir,ig)
     dje = dl(7,it,ir,ig)
     dlte = dl(5,it,ir,ig)
     rdcoll = da*gctg(it,ir,ig)
  endif
  absmol = rdcoll/(acoeff+rdcoll)

  wdopp = vz*wec
  dwdopp = abs(wdopp0-wdopp)/two
  wdopp0 = wdopp
  if(iz.eq.1) dwdopp = dwdopp*2./3.
  !	I ought to multiply by 4/3 going back out a grid
  dwr = sqrt((dvturb0**2+dvturb1**2*au/r)*wec**2+dw**2)
  if(dwr.eq.zero) then
     print '(" dwturb = dw = 0.")'
     stop
  endif
  dwhwzi = dwdopp+4.*dwr
  phiint = two*dwdopp+sqrtpi*dwr
  fpi = zero
  fqi = zero
  fri = zero
  wp3 = wp0**3
  wq3 = wq0**3
  wr3 = wr0**3
  wmid = (nw+one)/two
  opacdp = opl(1,it,ir,ig)
  taudp = opacdp*ds
  expdp = sexp(-taudp)
  opacdq = opl(2,it,ir,ig)
  taudq = opacdq*ds
  expdq = sexp(-taudq)
  opacdr = opl(3,it,ir,ig)
  taudr = opacdr*ds
  expdr = sexp(-taudr)
  taud = max(taudp,taudq,taudr)
  gju = two*xju+one
  gjp = two*xjp+one
  gjq = two*xjq+one
  gjr = two*xjr+one
  if((moltype.eq.1).or.(moltype.eq.4)) then
     !	diatomic opacities
     opfacp = (djp/gjp-dju/gju)*xjp*sv*(wp0/we)
     opfacq = zero
     opfacr = (djr/gjr-dju/gju)*xju*sv*(wr0/we)
     emfacp = two*hc2*wp3*sv*dju*xjp/gju
     emfacq = zero
     emfacr = two*hc2*wr3*sv*dju*xju/gju
  elseif((moltype.eq.2).or.(moltype.eq.5)) then
     !	HCN, C2H2 opacities
     opfacp = (djp/gjp-dju/gju)*(xjp-one)*sv*(wp0/we)
     opfacq = grat*(djq-dje)*sv
     opfacr = (djr/gjr-dju/gju)*(xju+one)*sv*(wr0/we)
     emfacp = two*hc2*wp3*sv*dju*(xjp-one)/gju
     emfacq = grat*two*hc2*wq3*sv*dje
     emfacr = two*hc2*wr3*sv*dju*(xju+one)/gju
  elseif(moltype.eq.3) then
     !	NH3 opacities
     opfacp = (djp/gjp-dju/gju)*(xjp-xk*xk/xjp)*sv*(wp0/we)
     opfacq = ((djq-dju)*xk*xk/(xju*(xju+one)))*sv
     opfacr = (djr/gjr-dju/gju)*(xju-xk*xk/xju)*sv*(wr0/we)
     emfacp = two*hc2*wp3*sv*dju*(xjp-xk*xk/xjp)/gju
     emfacq = two*hc2*wq3*sv*dju*xk*xk/(xju*(xju+one))
     emfacr = two*hc2*wr3*sv*dju*(xju-xk*xk/xju)/gju
  elseif(moltype.eq.11) then
     !	rotational xitions of diatomics
     opfacr = (djr/gjr-dju/gju)*xju*sv
     emfacr = two*hc2*wr3*sv*(xju/gju)*dju
  elseif(doprint) then
     print '("Undefined moltype")'
     stop
  endif
  if(emfacp.lt.zilch) emfacp = zero
  if(emfacq.lt.zilch) emfacq = zero
  if(emfacr.lt.zilch) emfacr = zero
  good = .true.

  taup0 = opfacp*ds/phiint
  tauq0 = opfacq*ds/phiint
  taur0 = opfacr*ds/phiint
  if(docheck.and.(taur0.lt.(-tiny)).or.(tauq0.lt.(-tiny))) then
     print '("Warning: tau0 =",1p,3e10.2," at",3i6)', &
          taup0,tauq0,taur0,it,ir,ig
     print '("nj =",1p,6e10.2)', djr,djq,djp,dju,dje,dlte
     docheck = .false.
  endif
  taumax = max(taup0,tauq0,taur0)
  if(taumax.gt.tiny) then
     dwmax = dwdopp+dwr*sqrt(log(taumax/tiny))
  else
     dwmax = dwdopp
  endif
  if(dwmax.lt.dw) dwmax = zero
  phisum = zero
  !	loop over frequencies
  do iw = 1,nw
     fwp0 = fwi(iw,1)
     fwq0 = fwi(iw,2)
     fwr0 = fwi(iw,3)
     w = (iw-wmid)*dw
     deltaw = abs(w-wdopp)
     if((dwmax.gt.zero).and.(iw.gt.1).and.(iw.lt.nw)) then
        !	include line opacity
        if(deltaw.lt.dwmax) then
           !	crude convolution of Gaussian with box
           if(deltaw.lt.dwdopp) then
              phiw = one
           else
              !                phiw = sexp(-((deltaw-dwdopp)/dwr)**2)
              arg = hun*((deltaw-dwdopp)/dwr)**2
              if(arg.lt.big) then
                 iarg = int(arg)
                 darg = (arg-iarg)/hun
                 phiw = (one-darg+darg**2/too)*expi(iarg+1)
              else
                 phiw = zero
              endif
           endif
           phiw = phiw/phiint
           phiwdw = phiw*dw
           phisum = phisum+phiwdw
           opacp = opacdp+opfacp*phiw
           opacq = opacdq+opfacq*phiw
           opacr = opacdr+opfacr*phiw
           emisp = opacdp*spd+emfacp*phiw
           emisq = opacdq*sqd+emfacq*phiw
           emisr = opacdr*srd+emfacr*phiw
           if((emisp.gt.zilch).and.(opacp.gt.zilch)) then
              sp = emisp/opacp
           else
              sp = zero
           endif
           if((emisq.gt.zilch).and.(opacq.gt.zilch)) then
              sq = emisq/opacq
           else
              sq = zero
           endif
           if((emisr.gt.zilch).and.(opacr.gt.zilch)) then
              sr = emisr/opacr
           else
              sr = zero
           endif
           !	optical depths
           taulp = opfacp*phiw*ds
           taulq = opfacq*phiw*ds
           taulr = opfacr*phiw*ds
           taup = taudp+taulp
           tauq = taudq+taulq
           taur = taudr+taulr
           !	P-branch line
           !	changed to allow negative tauline
           if(taulp.lt.zero) then
              expp = expdp*(one-taulp)
              fwp1 = fwp0*expp+spd*(one-expdp)+emfacp*phiw*ds
              fwp2 = (fwp0+fwp1)/two
              !                fwp2 = (fwp0-fwp1)/taup+sp
           else
              !                expp = sexp(-taup)
              arg = hun*taup
              if(arg.lt.small) then
                 expp = one-taup
                 fwp1 = fwp0*expp+sp*taup
              elseif(arg.lt.big) then
                 iarg = int(arg)
                 darg = (arg-iarg)/hun
                 expp = (one-darg+darg**2/too)*expi(iarg+1)
                 fwp1 = fwp0*expp+sp*(one-expp)
              else
                 fwp1 = sp
              endif
              if(taup.lt.small) then
                 fwp2 = (fwp0+fwp1)/two
              elseif(taup.lt.one) then
                 fwp2 = (fwp0-fwp1)/taup+sp
              else
                 !	take diffusion approximation within cell for mean intensity in cell
                 tauabs = (taup-taudp)*absmol
                 taueff = sqrt((taudp+tauabs)*taup)
                 arg = hun*taueff
                 if(arg.lt.big) then
                    iarg = int(arg)
                    darg = (arg-iarg)/hun
                    expeff = (one-darg+darg**2/too)*expi(iarg+1)
                    fwp2 = (fwp0-spd)*(one-expeff)/taueff+spd
                 else
                    fwp2 = spd
                 endif
              endif
           endif
           fpi = fpi+phiwdw*fwp2
           !	Q-branch line
           if(taulq.lt.zero) then
              expq = expdq*(one-taulq)
              fwq1 = fwq0*expq+sqd*(one-expdp)+emfacq*phiw*ds
              fwq2 = (fwq0+fwq1)/two
           else
              arg = hun*tauq
              if(arg.lt.small) then
                 expq = one-tauq
                 fwq1 = fwq0*expq+sq*tauq
              elseif(arg.lt.big) then
                 iarg = int(arg)
                 darg = (arg-iarg)/hun
                 expq = (one-darg+darg**2/too)*expi(iarg+1)
                 fwq1 = fwq0*expq+sq*(one-expq)
              else
                 fwq1 = sq
              endif
              if(tauq.lt.small) then
                 fwq2 = (fwq0+fwq1)/two
              elseif(tauq.lt.one) then
                 fwq2 = (fwq0-fwq1)/tauq+sq
              else
                 tauabs = (tauq-taud)*absmol
                 taueff = sqrt((taud+tauabs)*tauq)
                 arg = hun*taueff
                 if(arg.lt.big) then
                    iarg = int(arg)
                    darg = (arg-iarg)/hun
                    expeff = (one-darg+darg**2/too)*expi(iarg+1)
                    fwq2 = (fwq0-sqd)*(one-expeff)/taueff+sqd
                 else
                    fwq2 = sqd
                 endif
              endif
           endif
           fqi = fqi+phiwdw*fwq2
           !	R-branch line
           if(taulr.lt.zero) then
              expr = expdr*(one-taulr)
              fwr1 = fwr0*expr+srd*(one-expdr)+emfacr*phiw*ds
              fwr2 = (fwr0+fwr1)/two
           else
              arg = hun*taur
              if(arg.lt.small) then
                 expr = one-taur
                 fwr1 = fwr0*expr+sr*taur
              elseif(arg.lt.big) then
                 iarg = int(arg)
                 darg = (arg-iarg)/hun
                 expr = (one-darg+darg**2/too)*expi(iarg+1)
                 fwr1 = fwr0*expr+sr*(one-expr)
              else
                 fwr1 = sr
              endif
              if(taur.lt.small) then
                 fwr2 = (fwr0+fwr1)/two
              elseif(taur.lt.one) then
                 fwr2 = (fwr0-fwr1)/taur+sr
              else
                 tauabs = (taur-taudr)*absmol
                 taueff = sqrt((taudr+tauabs)*taur)
                 arg = hun*taueff
                 if(arg.lt.big) then
                    iarg = int(arg)
                    darg = (arg-iarg)/hun
                    expeff = (one-darg+darg**2/too)*expi(iarg+1)
                    fwr2 = (fwr0-srd)*(one-expeff)/taueff+srd
                 else
                    fwr2 = srd
                 endif
              endif
           endif
           fri = fri+phiwdw*fwr2
        else
           !	include only dust off line
           fwp1 = fwp0*expdp+spd*(one-expdp)
           fwq1 = fwq0*expdq+sqd*(one-expdq)
           fwr1 = fwr0*expdr+srd*(one-expdr)
           taup = taudp
           tauq = taudq
           taur = taudr
        endif
     else
        !	no line opacity, include only dust
        fwp1 = fwp0*expdp+spd*(one-expdp)
        fwq1 = fwq0*expdq+sqd*(one-expdq)
        fwr1 = fwr0*expdr+srd*(one-expdr)
        if(deltaw.lt.dwr) then
           phiwdw = dw/(2.*dwr)
           phisum = phisum+phiwdw
           fpi = fpi+phiwdw*fwp1
           fqi = fqi+phiwdw*fwq1
           fri = fri+phiwdw*fwr1
        endif
        taup = taudp
        tauq = taudq
        taur = taudr
     endif
     !	intensity leaving cell
     fwi(iw,1) = fwp1
     fwi(iw,2) = fwq1
     fwi(iw,3) = fwr1
     if(good.and.(badnum(fwp1).or.(fwp1.lt.0.)))then
        print '(" fwp1 bad",2i6,1p,5e10.3)', iw,ig,x,y,z,opacp,emisp
        print '(1p,8e9.2)', taup,taudp,fwp1,fwp0,expp,sp,expdp,spd
        good = .false.
     endif
     if(good.and.(badnum(fwq1).or.(fwq1.lt.0.)))then
        print '(" fwq1 bad",2i6,1p,5e10.3)', iw,ig,x,y,z,opacp,emisp
        print '(1p,8e9.2)', tauq,taudq,fwq1,fwq0,expq,sq,expdq,sqd
        good = .false.
     endif
     if(good.and.(badnum(fwr1).or.(fwr1.lt.0.)))then
        print '(" fwr1 bad",2i6,1p,5e10.3)', iw,ig,x,y,z,opacr,emisr
        print '(1p,8e9.2)', taur,taudr,fwr1,fwr0,expr,sr,expdr,srd
        good = .false.
     endif
     !       calculate optical depths (print in grid1)
     if((jg.eq.ng9).and.(ix.eq.lx2) &
          .and.(deltaw.lt.dw2)) then
        tauline = tauline+taur-taudr
     endif
  enddo  !  iw
  if((jg.eq.ng9).and.(ix.eq.lx2)) then
     taucont = taucont+taudr
  endif

  !	put integrated intensities in mean intensity arrays
  if(abs(wdopp).lt.(wmid*dw)) then
     if(phisum.eq.zero) phisum = one
     ff(1,it,ir,ig) = ff(1,it,ir,ig)+gwt*fpi/phisum
     ff(2,it,ir,ig) = ff(2,it,ir,ig)+gwt*fqi/phisum
     ff(3,it,ir,ig) = ff(3,it,ir,ig)+gwt*fri/phisum
  else
     !	this is probably wrong physically
     ff(1,it,ir,ig) = ff(1,it,ir,ig)+gwt*fwi(1,1)
     ff(2,it,ir,ig) = ff(2,it,ir,ig)+gwt*fwi(1,2)
     ff(3,it,ir,ig) = ff(3,it,ir,ig)+gwt*fwi(1,3)
  endif
  ff(4,it,ir,ig) = ff(4,it,ir,ig)+gwt*fwi(1,2)
  fn(it,ir,ig) = fn(it,ir,ig)+gwt

  return
end subroutine stepl



subroutine movie(nc,ic)
  !	put cube into movie frames and write to disk

  implicit real*8 (a-h,o-z)
  parameter (mc = 256)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /angls/ dcost,dcos9,rot,irot
  common /cube/ cube(mc,mc,mc),ngc
  dimension frame(mc,mc)
  character*16 lockline

  !	make and plot continuum frame
  cosrot = cos(rot)
  xmid = (nc+1)/two
  nc2 = nc/2
  sumcon = zero
  do iy = 1,nc
     do ix = 1,nc
        x = (ix-xmid)/cosrot
        y = iy-xmid
        scale = sqrt(x**2+y**2)
        scale = (x**2+y**2)
        if(scale.lt.one) scale = zero
        frame(ix,iy) = sqrt(max(zero,scale*cube(ix,iy,ic)))
        sumcon = sumcon+frame(ix,iy)
     enddo
  enddo
  if(sumcon.eq.zero) then
     print '(" continuum = 0")'
     return
  endif
18 open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=19)
  read(8,'(a16)') lockline
  close(unit=8)
  if(index(lockline,'reading').gt.0) then
     call sleep(1)
     goto 18
  endif
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=19)
  write(8,'("writing")')
  close(unit=8)
  open(unit=9,file='/home/r900-1/lacy/plotr/images', &
       access='direct',err=19,recl=2*nc)
  irec = 0
  do iy = 1,nc
     irec = irec+1
     write(unit=9,rec=irec) (frame(ix,iy),ix=1,nc)
  enddo
  nfr = 1
  if(lw.lt.(nw/2)) goto 17

  !	make and plot line movie
  idw = nc/32
  xdw = idw
  nw1 = nc/8+idw/2
  nw2 = nc/4+idw/2
  nw3 = 3*nc/8+idw/2
  do iw = nw2,nw3,idw
     sumsum = zero
     do iy = 1,nc
        do ix = 1,nc
           sumj = -xdw*cube(ix,iy,ic)
           do jw = iw,iw+idw-1
              sumj = sumj+cube(ix,iy,jw)
           enddo
           x = (ix-xmid)/cosrot
           y = iy-xmid
           scale = sqrt(x**2+y**2)/xdw
           scale = (x**2+y**2)/xdw
           !              if(scale.lt.one) scale = zero
           frame(ix,iy) = scale*sumj
           sumsum = sumsum+abs(scale*sumj)
        enddo
     enddo
     if(sumsum.gt.(sumcon/1.0d+06)) then
        !            print '(" iw =",i4," -",i4,1p,2e10.2)', &
        !              iw,iw+idw-1,sumsum,sumcon
        do iy = 1,nc
           irec = irec+1
           write(unit=9,rec=irec) (frame(ix,iy),ix=1,nc)
        enddo
        nfr = nfr+1
     endif
  enddo

  !	make line frame
  nc2 = nc/2
  sumsum = zero
  do iy = 1,nc
     do ix = 1,nc
        x = (ix-xmid)/cosrot
        y = iy-xmid
        scale = sqrt(x**2+y**2)
        scale = (x**2+y**2)
        !            if(scale.lt.one) scale = zero
        sum = -(nc2-2)*cube(ix,iy,ic)
        do iw = 2,nc2-1
           sum = sum+cube(ix,iy,iw)
        enddo
        sum = scale*sum
        frame(ix,iy) = sum
        sumsum = sumsum+abs(sum)
     enddo
  enddo
  if(sumsum.ne.zero) then
     do iy = 1,nc
        irec = irec+1
        write(unit=9,rec=irec) (frame(ix,iy),ix=1,nc)
     enddo
     nfr = nfr+1
  endif
17 close(unit=9)
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=19)
  write(8,'("images")')
  write(8,'(3i8)') nc,nc,nfr
  close(unit=8)

19 return
end subroutine movie



subroutine convo(fw,spec,fwnorm,dvdpix,dsm,nsm)
  !	convolve spectrum with gaussian resolution function

  implicit real*8 (a-h,o-z)
  parameter (mw = 1024)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  dimension fw(mw),spec(mw)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)

  sumss = zero
  do iw = 1,nw
     sums = fw(iw)
     sumg = one
     do ism = 1,nsm
        iwm = iw-ism
        iwp = iw+ism
        if((iwm.ge.1).and.(iwp.le.nw)) then
           gaus = sexp(-(ism/dsm)**2)
           sumg = sumg+two*gaus
           sums = sums+gaus*(fw(iwm)+fw(iwp))
        endif
     enddo
     speci = sums/(sumg*fwnorm)
     spec(iw) = speci
     sumss = sumss+speci
  enddo
  cont = (fw(1)+fw(nw))/(two*fwnorm)
  ew = (nw-sumss/cont)*dvdpix
  if(abs(ew).lt.(1.0d+03)) then
     print '(" EW = ",f8.3)', ew
     write(16,'(" EW = ",f8.3)') ew
  elseif(abs(ew).lt.(1.0d+10)) then
     print '(" EW = ",1p,e10.3)', ew
     write(16,'(" EW = ",1p,e10.3)') ew
  else
     print '(" In convo fwnorm,sumss,cont,ew=",1p,4e10.2)', &
          fwnorm,sumss,cont,ew
     write(16,'(" In convo fwnorm,sumss,cont,ew=",1p,4e10.2)') &
          fwnorm,sumss,cont,ew
  endif

  return
end subroutine convo



subroutine zerof(nul)
  !	zero ff and fn

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ml = 8)
  parameter (mu = 64)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  parameter (zero = 0.0d+00)

  do ig = 1,ng
     do ir = 1,nr
        do it = 1,nt
           do il = 1,nul
              ff(il,it,ir,ig) = zero
           enddo
           fn(it,ir,ig) = zero
        enddo
     enddo
  enddo
  ig = ng9
  do ir = 1,nr9
     do it = 1,nt
        do il = 1,nul
           ff(il,it,ir,ig) = zero
        enddo
        fn(it,ir,ig) = zero
     enddo
  enddo

  return
end subroutine zerof


subroutine zerog(nul)
  !	zero gg and gn

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mu = 64)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  parameter (zero = 0.0d+00)

  do ig = 1,ng
     do ir = 1,nr
        do it = 1,nt
           do il = 1,nul
              gg(il,it,ir,ig) = zero
           enddo
           gn(it,ir,ig) = zero
        enddo
     enddo
  enddo
  ig = ng9
  do ir = 1,nr9
     do it = 1,nt
        do il = 1,nul
           gg(il,it,ir,ig) = zero
        enddo
        gn(it,ir,ig) = zero
     enddo
  enddo

  return
end subroutine zerog



subroutine copyarr(arr)
  !	copy array between grids

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  dimension arr(mt,mr,mg)
  logical badnum,doprint
  parameter (zero = 0.0d+00)
  parameter (two = 2.0d+00)

  doprint = (myrank.eq.0)
  nr2 = nr/2
  !	copy from expanded grid onto grid 1
  ig = 1
  jg = ng9
  xn9 = nn9**2
  nn8 = nn9-1
  nt8 = nt-nt/nn9+1
  do ir = 1,nr
     jr2 = nn9*ir
     jr1 = jr2-nn8
     do it = 1,nt,nn9
        suma = zero
        do jr = jr1,jr2
           do jt = it,it+nn8
              suma = suma+arr(jt,jr,jg)
           enddo
        enddo
        if(badnum(suma)) then
           if(doprint) print '(e10.2," in copyarr at",3i6)', &
                suma,it,jr1,jg
           suma = zero
        endif
        arr(it/nn9+nt8,ir,ig) = suma/xn9
     enddo
  enddo
  !	copy to inner half of next grid
  do ig = 2,ng
     jg = ig-1
     do ir = 1,nr2
        jr2 = 2*ir
        jr1 = jr2-1
        do it = 1,nt
           arr(it,ir,ig) = (arr(it,jr1,jg)+arr(it,jr2,jg))/two
           if(badnum(arr(it,ir,ig))) then
              if(doprint) print '(e10.2," in copyarr at",3i6)', &
                   arr(it,ir,ig),it,jr1,jg
              arr(it,ir,ig) = zero
           endif
        enddo
     enddo
  enddo

  return
end subroutine copyarr



subroutine copytau(arr)
  !	copy array between grids without averaging

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  dimension arr(mt,mr,mg)
  logical badnum,doprint
  parameter (zero = 0.0d+00)

  doprint = (myrank.eq.0)
  nr2 = nr/2
  !	copy from expanded grid onto grid 1
  ig = 1
  jg = ng9
  xn9 = nn9
  nn8 = nn9-1
  nt8 = nt-nt/nn9+1
  do ir = 1,nr
     jr = nn9*ir
     do it = 1,nt,nn9
        suma = zero
        do jt = it,it+nn8
           suma = suma+arr(jt,jr,jg)
        enddo
        if(badnum(suma)) then
           if(doprint) print '(e10.2," in copytau at",3i6)', &
                suma,it,jr,jg
           suma = zero
        endif
        arr(it/nn9+nt8,ir,ig) = suma/xn9
     enddo
  enddo
  !	copy to inner half of next grid
  do ig = 2,ng
     jg = ig-1
     do ir = 1,nr2
        jr = 2*ir
        do it = 1,nt
           arr(it,ir,ig) = arr(it,jr,jg)
        enddo
     enddo
  enddo

  return
end subroutine copytau



subroutine copywta(arr,wtarr)
  !	copy between grids with weighting

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (zero = 0.0d+00)
  parameter (two = 2.0d+00)
  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  dimension arr(mt,mr,mg),wtarr(mt,mr,mg)
  logical badnum,doprint

  doprint = (myrank.eq.0)
  nr2 = nr/2
  nn8 = nn9-1
  nt8 = nt-nt/nn9+1
  xn9 = nn9**2
  !	copy from expanded grid onto grid 1
  ig = 1
  jg = ng9
  do ir = 1,nr
     jr2 = nn9*ir
     jr1 = jr2-nn8
     do it = 1,nt,nn9
        suma = zero
        sumwt = zero
        do jr = jr1,jr2
           do jt = it,it+nn8
              suma = suma+arr(jt,jr,jg)*wtarr(jt,jr,jg)
              sumwt = sumwt+wtarr(jt,jr,jg)
           enddo
           if(badnum(suma)) then
              if(doprint) print '(e10.2," in copywta at",3i6)', &
                   suma,it,jr1,jg
              suma = zero
           endif
        enddo
        if(sumwt.gt.zero) then
           arr(it/nn9+nt8,ir,ig) = suma/sumwt
        else
           suma = zero
           do jr = jr1,jr2
              do jt = it,it+nn8
                 suma = suma+arr(jt,jr,jg)
              enddo
              if(badnum(suma)) then
                 if(doprint) print '(e10.2," in copywta at",3i6)', &
                      suma,it,jr1,jg
                 suma = zero
              endif
           enddo
           arr(it/nn9+nt8,ir,ig) = suma/xn9
        endif
     enddo
  enddo
  !	copy to inner half of next grid
  do ig = 2,ng
     jg = ig-1
     do ir = 1,nr2
        jr2 = 2*ir
        jr1 = jr2-1
        do it = 1,nt
           sumwt = wtarr(it,jr1,jg)+wtarr(it,jr2,jg)
           if(sumwt.gt.zero) then
              arr(it,ir,ig) = (arr(it,jr1,jg)*wtarr(it,jr1,jg) &
                   +arr(it,jr2,jg)*wtarr(it,jr2,jg))/sumwt
           else
              arr(it,ir,ig) = (arr(it,jr1,jg)+arr(it,jr2,jg))/two
           endif
           if(badnum(arr(it,ir,ig))) then
              if(doprint) print '(e10.2," in copywta at",3i6)', &
                   arr(it,ir,ig),it,jr1,jg
              arr(it,ir,ig) = zero
           endif
        enddo
     enddo
  enddo

  return
end subroutine copywta



subroutine copyarrr(arrr,mul,nul)
  !	copy 4-d array between grids

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  logical badnum,doprint
  dimension arrr(mul,mt,mr,mg)
  parameter (zero = 0.0d+00)
  parameter (two = 2.0d+00)

  doprint = (myrank.eq.0)
  nr2 = nr/2
  nn8 = nn9-1
  xn9 = nn9**2
  nt8 = nt-nt/nn9+1
  !	copy from expanded grid onto grid 1
  ig = 1
  jg = ng9
  do ir = 1,nr
     jr2 = nn9*ir
     jr1 = jr2-nn8
     do it = 1,nt,nn9
        do il = 1,nul
           suma = zero
           do jr = jr1,jr2
              do jt = it,it+nn8
                 suma = suma+arrr(il,jt,jr,jg)
              enddo
           enddo
           if(badnum(suma)) then
              if(doprint) print '(e10.2," in copyarrr at",4i6)', &
                   suma,il,it,jr1,jg
              suma = zero
           endif
           arrr(il,it/nn9+nt8,ir,ig) = suma/xn9
        enddo
     enddo
  enddo
  !	copy to inner half of next grid
  do ig = 2,ng
     jg = ig-1
     do ir = 1,nr2
        jr2 = 2*ir
        jr1 = jr2-1
        do it = 1,nt
           do il = 1,nul
              arrr(il,it,ir,ig) &
                   = (arrr(il,it,jr1,jg)+arrr(il,it,jr2,jg))/two
              if(badnum(arrr(il,it,ir,ig))) then
                 if(doprint) print '(e10.2," in copyarrr at",4i6)', &
                      arrr(il,it,ir,ig),il,it,jr1,jg
                 arrr(il,it,ir,ig) = zero
              endif
           enddo
        enddo
     enddo
  enddo

  return
end subroutine copyarrr



subroutine plotcon(con,logplot,monfile)
  !	make r-th contour plots

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (zero = 0.0d+00)
  parameter (two = 2.0d+00)
  parameter (four = 4.0d+00)
  parameter (tiny = 1.0d-06)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  dimension con(mt,mr,mg)
  logical logplot,monplot
  character*16 lockline,monfile
  dimension conmap(2*mt)
  tiny2 = tiny**2
  tiny4 = tiny2**2

  monplot = (index(monfile,' ').gt.1)
  nr2 = nr/2
  if(logplot) then
     conmin = slog10(tiny)
  else
     conmin = tiny
  endif

86 open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  read(8,'(a16)') lockline
  close(unit=8)
  if(index(lockline,'reading').gt.0) then
     call sleep(1)
     goto 86
  endif
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("writing")')
  close(unit=8)
  open(unit=9,file='/home/r900-1/lacy/plotr/contours', &
       access='direct',err=90,recl=2*nt)
  if(monplot) open(unit=10,file=monfile,access='direct',recl=2*nt)

  !	plot map of grid ng9
  irec = 0
  ig = ng9
  if(nr9.le.nt) then
     nxm = nt
     nym = nr9
     do ir = 1,nr9
        imap = 0
        do it = 1,nt
           coni = con(it,ir,ig)
           imap = imap+1
           if(logplot) then
              if(coni.gt.tiny) then
                 conmap(imap) = slog10(coni)
              elseif(coni.gt.zero) then
                 conmap(imap) = conmin
              else
                 conmap(imap) = zero
              endif
           else
              conmap(imap) = coni
           endif
        enddo  !  it
        irec = irec+1
        write(unit=9,rec=irec) (conmap(it),it=1,nt)
     enddo  !  ir
  elseif(nr9.le.(2*nt)) then
     nxm = 2*nt
     nym = nr9
     do ir = 1,nr9
        imap = 0
        do it = 1,nt
           coni = con(it,ir,ig)
           imap = imap+2
           if(logplot) then
              if(coni.gt.tiny) then
                 conmap(imap) = slog10(coni)
              elseif(coni.gt.zero) then
                 conmap(imap) = conmin
              else
                 conmap(imap) = zero
              endif
           else
              conmap(imap) = coni
           endif
           if(imap.gt.2) then
              conmap(imap-1) = (conmap(imap-2)+conmap(imap))/two
           else
              conmap(1) = conmap(2)
           endif
        enddo  !  it
        irec = irec+1
        write(unit=9,rec=irec) (conmap(it),it=1,nt)
        irec = irec+1
        write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
        if(monplot) then
           write(unit=10,rec=irec-1) (conmap(it),it=1,nt)
           write(unit=10,rec=irec) (conmap(it),it=nt+1,2*nt)
        endif
     enddo  !  ir
  else
     nxm = 2*nt
     nym = nr9/2
     do ir = 1,nr9,2
        imap = 0
        do it = 1,nt
           con1 = con(it,ir,ig)
           con2 = con(it,ir+1,ig)
           imap = imap+2
           if(logplot) then
              if(con1.gt.tiny) then
                 if(con2.gt.tiny) then
                    conmap(imap) = slog10(con1*con2)/two
                 else
                    conmap(imap) = slog10(con1)
                 endif
              elseif(con2.gt.tiny) then
                 conmap(imap) = slog10(con2)
              else
                 conmap(imap) = zero
              endif
           else
              conmap(imap) = (con1+con2)/two
           endif
           if(imap.gt.2) then
              conmap(imap-1) = (conmap(imap-2)+conmap(imap))/two
           else
              conmap(1) = conmap(2)
           endif
        enddo  !  it
        irec = irec+1
        write(unit=9,rec=irec) (conmap(it),it=1,nt)
        irec = irec+1
        write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
        if(monplot) then
           write(unit=10,rec=irec-1) (conmap(it),it=1,nt)
           write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
        endif
     enddo  !  ir
  endif

  close(unit=9)
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("contours")')
  write(8,'(3i8)') nxm,nym,1
  close(unit=8)
  call waitasec(.false.,4)

88 open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  read(8,'(a16)') lockline
  close(unit=8)
  if(index(lockline,'reading').gt.0) then
     call sleep(1)
     goto 88
  endif
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("writing")')
  close(unit=8)
  open(unit=9,file='/home/r900-1/lacy/plotr/contours', &
       access='direct',err=90,recl=2*nt)

  !	plot map of grids 1-ng
  jrec = irec
  irec = 0
  if((ng*nr/2).le.(2*nt)) then
     nxm = 2*nt
     nym = ng*nr2
     do ig = 1,ng
        do ir = nr2+1,nr
           imap = 0
           do it = 1,nt
              coni = con(it,ir,ig)
              imap = imap+2
              if(logplot) then
                 if(coni.gt.tiny) then
                    conmap(imap) = slog10(coni)
                 elseif(coni.gt.zero) then
                    conmap(imap) = conmin
                 else
                    conmap(imap) = zero
                 endif
              else
                 conmap(imap) = coni
              endif
              if(imap.gt.2) then
                 conmap(imap-1) = (conmap(imap-2)+conmap(imap))/two
              else
                 conmap(1) = conmap(2)
              endif
           enddo  !  it
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=1,nt)
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
           if(monplot) then
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=1,nt)
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=nt+1,2*nt)
           endif
        enddo  !  ir
     enddo  !  ig
  elseif((ng*nr/2).le.(4*nt)) then
     nxm = 2*nt
     nym = ng*nr2/2
     do ig = 1,ng
        do ir = nr2+1,nr,2
           imap = 0
           do it = 1,nt
              imap = imap+2
              if(logplot) then
                 prod = con(it,ir,ig)*con(it,ir+1,ig)
                 if(prod.gt.tiny2) then
                    conmap(imap) = slog10(prod)/two
                 elseif(prod.gt.zero) then
                    conmap(imap) = conmin
                 else
                    conmap(imap) = zero
                 endif
              else
                 conmap(imap) = (con(it,ir,ig)+con(it,ir+1,ig))/two
              endif
              if(imap.gt.2) then
                 conmap(imap-1) = (conmap(imap-2)+conmap(imap))/two
              else
                 conmap(1) = conmap(2)
              endif
           enddo  !  it
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=1,nt)
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
           if(monplot) then
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=1,nt)
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=nt+1,2*nt)
           endif
        enddo  !  ir
     enddo  !  ig
  else
     nxm = 2*nt
     nym = ng*nr2/4
     do ig = 1,ng
        do ir = nr2+1,nr,4
           imap = 0
           do it = 1,nt
              imap = imap+2
              if(logplot) then
                 prod = con(it,ir,ig)*con(it,ir+1,ig) &
                      *con(it,ir+2,ig)*con(it,ir+3,ig)
                 if(prod.gt.tiny4) then
                    conmap(imap) = slog10(prod)/four
                 elseif(prod.gt.zero) then
                    conmap(imap) = conmin
                 else
                    conmap(imap) = zero
                 endif
              else
                 conmap(imap) = (con(it,ir,ig)+con(it,ir+1,ig) &
                      +con(it,ir+2,ig)+con(it,ir+3,ig))/four
              endif
              if(imap.gt.2) then
                 conmap(imap-1) = (conmap(imap-2)+conmap(imap))/two
              else
                 conmap(1) = conmap(2)
              endif
           enddo  !  it
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=1,nt)
           irec = irec+1
           write(unit=9,rec=irec) (conmap(it),it=nt+1,2*nt)
           if(monplot) then
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=1,nt)
              jrec = jrec+1
              write(unit=10,rec=jrec) (conmap(it),it=nt+1,2*nt)
           endif
        enddo  !  ir
     enddo  !  ig
  endif

  close(unit=9)
  if(monplot) close(unit=10)
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("contours")')
  write(8,'(3i8)') nxm,nym,1
  close(unit=8)

90 return
end subroutine plotcon



subroutine plotim(frame,mx,nx,monfile)
  !	make greyscale plot of an image frame

  implicit real*8 (a-h,o-z)
  dimension frame(mx,mx)
  character*16 lockline,monfile
  logical monplot

  monplot = (index(monfile,' ').gt.1)
88 open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  read(8,'(a16)') lockline
  close(unit=8)
  if(index(lockline,'reading').gt.0) then
     call sleep(1)
     goto 88
  endif
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("writing")')
  close(unit=8)
  open(unit=9,file='/home/r900-1/lacy/plotr/images', &
       access='direct',err=90,recl=2*nx)
  if(monplot) open(unit=10,file=monfile,access='direct',recl=2*nx)

  do iy = 1,nx
     write(unit=9,rec=iy) (frame(ix,iy),ix=1,nx)
     if(monplot) write(unit=10,rec=iy) (frame(ix,iy),ix=1,nx)
  enddo

  close(unit=9)
  if(monplot) close(unit=10)
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("images")')
  write(8,'(3i8)') nx,nx,1
  close(unit=8)

90 return
end subroutine plotim


subroutine plotggfs(gg,jg,ju)
  !	make grey plot of mean intensity / stellar

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mu = 64)
  parameter (ma = 32)
  parameter (mc = 1024)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (hun = 1.0d+02)

  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  dimension gg(mu,mt,mr,mg)
  dimension frame(mc,mc)
  logical badnum

  nc = mc
  alog2 = log(two)
  call startgr(jg,ig,kr,lr,lt,dr,dcost)
  if(ig.gt.ng) then
     dxm = (nr9*dr9)/nc
     x0 = -half*dxm
     zstr = nn9
  else
     dxm = (nr*dr)/nc
     x0 = -half*dxm
     zstr = one
  endif
  rnr = nr*dr0
  summap = zero
  summi = zero
  do ix = 1,nc
     do iz = 1,nc
        x = x0+ix*dxm
        y = zero
        z = (iz-nc/2-half)*dxm
        !	stretch z scale
        z = z/zstr
        r = sqrt(x**2+y**2+z**2)
        costh = abs(z/r)
        if(r.le.rstar) then
           frame(ix,iz) = zero
           goto 240
        endif
        if(ig.gt.ng) then
           it = nt-nint(costh/dcost-half)
           if((it.ge.1).and.(it.le.nt)) then
              call startgr(jg,kg,kr,lr,lt,drgr,dcosgr)
              ir = r/dr9+one
              ir = min(nr9,max(1,ir))
           else
              igr = slog(r/rnr)/alog2+one
              igr = min(ng,max(1,igr))
              call startgr(igr,kg,kr,lr,lt,drgr,dcosgr)
              ir = r/drgr+one
              ir = min(nr,max(1,ir))
              it = nt-nint(costh/dcosgr-half)
              if((it.lt.1).or.(it.gt.nt).or.(ir.lt.1).or.(ir.gt.nr)) &
                   then
                 frame(ix,iz) = one
                 goto 240
              endif
           endif
        else
           igr = slog(r/rnr)/alog2+one
           igr = min(ng,max(1,igr))
           call startgr(igr,kg,kr,lr,lt,drgr,dcosgr)
           ir = r/drgr+one
           ir = min(nr,max(1,ir))
           it = nt-nint(costh/dcosgr-half)
           if((it.lt.1).or.(it.gt.nt).or.(ir.lt.1).or.(ir.gt.nr)) &
                then
              frame(ix,iz) = one
              goto 240
           endif
        endif
        if(condens(na/4,it,ir,kg).eq.zero) then
           frame(ix,iz) = one
           goto 240
        endif
        if(r.lt.(hun*rstar)) then
           ostar = (one-sqrt(one-(rstar/r)**2))/two
        else
           ostar = (rstar/(two*r))**2
        endif
        if(ju.eq.0) then
           ggsum = zero
           fssum = zero
           do iu = 1,nu
              ggsum = ggsum+opa(iu,nt,nr,1)*gg(iu,it,ir,kg)*dud(iu)
              fssum = fssum+opa(iu,nt,nr,1)*bus(iu)*dud(iu)
           enddo
           if(fssum.gt.zero) then
              ggfs = ggsum/(fssum*ostar)
           else
              ggfs = one
           endif
        elseif(ju.lt.0) then
           ia = abs(ju)
           ggsum = zero
           fssum = zero
           do iu = 1,nu
              ggsum = ggsum+phab(iu,ia)*gg(iu,it,ir,kg)*dud(iu)
              fssum = fssum+phab(iu,ia)*bus(iu)*dud(iu)
           enddo
           if(fssum.gt.zero) then
              ggfs = ggsum/(fssum*ostar)
           else
              ggfs = one
           endif
        else
           ggfs = gg(ju,it,ir,kg)/(bus(ju)*ostar)
        endif
        if(badnum(ggfs)) then
           print '(" in ggfs:",5i6,1p,2e10.2)', &
                ix,iz,it,ir,kg,gg(ju,it,ir,kg),bus(ju)
           ggfs = zero
        endif
        summap = summap+ggfs
        summi = summi+one
        frame(ix,iz) = sqrt(ggfs)
240  enddo
  enddo

  print '(" plotting sqrt(gg/stellar) with z stretch =",f4.1)', &
       zstr
  !        print '(" mean gg/fs =",1p,e10.3)', summap/summi
  call plotim(frame,mc,nc,'')

  return
end subroutine plotggfs


subroutine plotxyim(pl,jg)
  !	make a grey plot of an array transformed onto xy coordinates

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (mc = 1024)
  parameter (zero = 0.0d+00)
  parameter (half = 0.5d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)

  common /mpis/mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /parms/ dx0,dz0,dr0,dw,dvturb0,dvturb1,vterm,rstar,tstar
  dimension pl(mt,mr,mg)
  dimension frame(mc,mc)

  nc = mc
  alog2 = log(two)
  call startgr(jg,ig,kr,lr,lt,dr,dcost)
  if(ig.gt.ng) then
     rnr = kr*dr
     dxm = rnr/(2*nc)
     x0 = (nc-half)*dxm
  else
     dxm = dr
     rnr = nr*dr0
     x0 = -half*dxm
  endif
  summap = zero
  summi = zero
  do ix = 1,nc
     do iz = 1,nc
        x = x0+ix*dxm
        y = zero
        z = (iz-nc/2-half)*dxm
        r = sqrt(x**2+y**2+z**2)
        costh = abs(z/r)
        if(ig.gt.ng) then
           it = nt-nint(costh/dcost-half)
           if((it.ge.1).and.(it.le.nt)) then
              igr = ig
              drgr = dr9
              ir = r/dr9+one
              ir = min(nr9,max(1,ir))
           else
              igr = slog(r/rnr)/alog2+one
              igr = min(ng,max(1,igr))
              call startgr(igr,kg,kr,lr,lt,dr,dcosgr)
              drgr = dr
              ir = r/drgr+one
              ir = min(nr,max(1,ir))
              it = nt-nint(costh/dcosgr-half)
              if((it.lt.1).or.(it.gt.nt)) then
                 frame(ix,iy) = zero
                 goto 240
              endif
           endif
        else
           igr = slog(r/rnr)/alog2+one
           igr = min(ng,max(1,igr))
           call startgr(igr,kg,kr,lr,lt,dr,dcosgr)
           drgr = dr
           ir = r/drgr+one
           ir = min(nr,max(1,ir))
           it = nt-nint(costh/dcosgr-half)
           if((it.lt.1).or.(it.gt.nt)) then
              frame(ix,iy) = zero
              goto 240
           endif
        endif
        if(r.le.rstar) then
           frame(ix,iz) = zero
           goto 240
        elseif(r.lt.(100.*rstar)) then
           ostar = (one-sqrt(one-(rstar/r)**2))/2.
        else
           ostar = 0.25*(rstar/r)**2
        endif
        !            frame(ix,iz) = pl(it,ir,kg)/ostar
        frame(ix,iz) = pl(it,ir,kg)*(r/rstar)
        summap = summap+frame(ix,iz)
        summi = summi+one
        frame(ix,iz) = max(frame(ix,iz),zero)
240  enddo
  enddo

  call plotim(frame,mc,nc,'')

  return
end subroutine plotxyim


subroutine plotspec(spec,mw,nw,nspec,irot,dw,monfile)
  !	plot spectrum

  implicit real*8 (a-h,o-z)
  dimension spec(mw,nspec)
  character*16 lockline,monfile
  logical monplot

  monplot = (index(monfile,' ').gt.1)
88 open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  read(8,'(a16)') lockline
  close(unit=8)
  if(index(lockline,'reading').gt.0) then
     call sleep(1)
     goto 88
  endif
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("writing")')
  close(unit=8)
  open(unit=9,file='/home/r900-1/lacy/plotr/specs', &
       access='direct',err=90,recl=2*nw)
  if(monplot) open(unit=10,file=monfile,access='direct',recl=2*nw)

  do ispec = 1,nspec
     write(unit=9,rec=ispec) (spec(iw,ispec),iw=1,nw)
     jspec = (irot-1)*nspec+ispec
     if(monplot) write(unit=10,rec=jspec) (spec(iw,ispec),iw=1,nw)
  enddo

  close(unit=9)
  if(monplot) close(unit=10)
  open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
       access='sequential',err=90)
  write(8,'("specs")')
  write(8,'(2i8,1p,e12.3)') nw,nspec,dw
  close(unit=8)

90 return
end subroutine plotspec



function bw(w,t)
  !	black body function

  implicit real*8 (a-h,o-z)
  parameter (hc2 = 5.955d-06)
  parameter (hck = 1.4388d+00)
  parameter (big = 5.0d+02)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)

  arg = hck*w/t
  if(arg.le.zero) then
     bw = zero
  elseif(arg.lt.big) then
     bw = two*hc2*w**3/(sexp(arg)-one)
  else
     bw = zero
  endif

  return
end function bw


function texp(arg)
  !	exp(arg) using look-up table

  implicit real*8 (a-h,o-z)
  common /exptab/ expi(10239),too
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (hun = 1.0d+02)
  parameter (big = 1.0d+04)

  harg = abs(hun*arg)
  if(harg.lt.big) then
     iarg = int(harg)
     darg = (harg-iarg)/hun
     texp = (one-darg+darg**2/too)*expi(iarg+1)
     if(arg.gt.zero) texp = one/texp
  elseif(arg.lt.zero) then
     texp = zero
  else
     texp = one/expi(10000)
  endif

  return

  entry expinit

  do iarg = 1,10000
     expi(iarg) = sexp(-(iarg-1)/hun)
  enddo
  darg = one/hun
  too = darg**2/(exp(-darg)-one+darg)
  expinit = one

  return
end function texp


function sexp(arg)
  !	safe and efficient exp function

  implicit real*8 (a-h,o-z)
  parameter (big = 4.6d+02)
  parameter (small = 1.0d-03)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  save nan
  if((nan.lt.0).or.(nan.gt.8)) nan = 0

  if(arg.lt.(-big)) then
     sexp = zero
  elseif(arg.gt.big) then
     sexp = 1.0d+200
  elseif(abs(arg).lt.small) then
     sexp = 1.0+arg+arg**2/two
  elseif((arg.lt.zero).or.(arg.gt.zero)) then
     sexp = exp(arg)
  else  !  NaN
     print '(e10.2," passed to sexp",i6)', arg,nan
     nan = nan+1
     if(nan.gt.8) stop
     sexp = one
  endif

  return
end function sexp


function slog(arg)
  !	safe log function

  implicit real*8 (a-h,o-z)
  parameter (tiny = 1.0d-200)
  parameter (big = 1.0d+200)
  parameter (small = 1.0d-03)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  save nan
  if((nan.lt.0).or.(nan.gt.8)) nan = 0

  if(arg.le.zero) then
     slog = -500.
  elseif(arg.lt.tiny) then
     slog = -460.
  elseif(arg.gt.big) then
     slog = 460.
  elseif(abs(arg-one).lt.small) then
     slog = arg-one
     slog = slog-slog**2/two
  elseif(arg.gt.tiny) then
     slog = log(arg)
  else  !  NaN
     if(nan.le.8) print '(e10.2," passed to slog",i6)', arg
     nan = nan+1
     slog = zero
  endif

  return
end function slog


function slog10(arg)
  !	safe log_10 function

  implicit real*8 (a-h,o-z)
  parameter (tiny = 1.0d-200)
  parameter (big = 1.0d+200)
  parameter (small = 1.0d-03)
  parameter (aloge = 0.4342945d+00)
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  save nan
  if((nan.lt.0).or.(nan.gt.8)) nan = 0

  if(arg.le.zero) then
     slog10 = -250.
  elseif(arg.lt.tiny) then
     slog10 = -200.
  elseif(arg.gt.big) then
     slog10 = 200.
  elseif(abs(arg-one).lt.small) then
     slog = arg-one
     slog10 = aloge*(slog-slog**2/two)
  elseif(arg.gt.tiny) then
     slog10 = log10(arg)
  else  !  NaN
     if(nan.le.8) print '(e10.2," passed to slog10",i6)', arg
     nan = nan+1
     slog10 = zero
  endif

  return
end function slog10


subroutine waitasec(wait,iwait)
  !	wait until ploto is done with a plot

  implicit real*8 (a-h,o-z)
  common /mpis/mysize,myrank
  logical wait
  character*16 lockline

  if(wait) then
     call sleep(iwait-1)
100  call sleep(1)
     open(unit=8,file='/home/r900-1/lacy/plotr/plotlock', &
          access='sequential',err=90)
     read(8,'(a16)') lockline
     close(unit=8)
     if(index(lockline,'empty').eq.0) goto 100
  else
     call sleep(iwait)
  endif

90 return
end subroutine waitasec


subroutine savemodel
  !	save a disk model to allow reusing it

  implicit real*8 (a-h,o-z)
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /mean/ gg(mu,mt,mr,mg),gn(mt,mr,mg),gguv(mt,mr,mg), &
       ff(mu,mt,mr,mg),fn(mt,mr,mg)
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  parameter (pi = 3.14159265d+00)

  open(unit=9,file='diskmodel',access='direct',recl=2*nt)
  irec = 0
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        irec = irec+1
        write(unit=9,rec=irec) (dg(it,ir,ig),it=1,nt)
     enddo
  enddo
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        irec = irec+1
        write(unit=9,rec=irec) (tg(it,ir,ig),it=1,nt)
     enddo
  enddo
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        irec = irec+1
        write(unit=9,rec=irec) (td(it,ir,ig),it=1,nt)
     enddo
  enddo
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        irec = irec+1
        write(unit=9,rec=irec) (opl(ml,it,ir,ig),it=1,nt)
     enddo
  enddo
  close(unit=9)
  print '(" wrote to diskmodel",2i8," byte records")', irec,8*nt
  irec = 0
  open(unit=9,file='dustmodel',access='direct',recl=2*nu)
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        do it = 1,nt
           irec = irec+1
           write(unit=9,rec=irec) (opa(iu,it,ir,ig),iu=1,nu)
        enddo
     enddo
  enddo
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        do it = 1,nt
           irec = irec+1
           write(unit=9,rec=irec) (swd(iu,it,ir,ig),iu=1,nu)
        enddo
     enddo
  enddo
  close(unit=9)
  print '(" wrote to dustmodel",2i8," byte records")', irec,8*nu

  open(unit=10,file='disk.out')
  do igr = 0,ng
     call startgr(igr,ig,kr,lr,lt,dr,dcosth)
     do ir = kr,lr
        r = dr*(ir-half)
        do it = 1,nt
           z = r*dcosth*(nt-it+half)
           sumd = zero
           ddi = dd(it,ir,ig)
           dgi = dg(it,ir,ig)
           do ia = 1,na
              sumd = sumd+condens(ia,it,ir,ig)*sexp(-ad(ia)*ddi) &
                   *dgi*popd(ia)*pi*ad(ia)**2
           enddo
           write(10,'(3i6,1p,7e10.3)') igr,ir,it,r,z, &
                dg(it,ir,ig),tg(it,ir,ig),td(it,ir,ig),gguv(it,ir,ig), &
                sumd
        enddo
     enddo
  enddo

  return
end subroutine savemodel


subroutine readmodel(chemfile,xburn)
  !	read in a saved model

  implicit real*8 (a-h,o-z)
#include "mpif.h"
  parameter (mg = 20)
  parameter (mr = 128)
  parameter (mt = 192)
  parameter (ma = 32)
  parameter (ml = 8)
  parameter (mu = 64)
  parameter (mw = 1024)
  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /dust/ ad(ma),popd(ma),wd(mu),ud(mu),dud(mu),bus(mu), &
       phid(mu,ma),phab(mu,ma),phsc(mu,ma),dd(mt,mr,mg), &
       opa(mu,mt,mr,mg),sca(mu,mt,mr,mg),swd(mu,mt,mr,mg), &
       rebus(mu),condens(ma,mt,mr,mg),td(mt,mr,mg)
  common /gas/ dg(mt,mr,mg),tg(mt,mr,mg),gctg(mt,mr,mg),fstar(ml), &
       wl(ml),dl(ml,mt,mr,mg),sl(ml,mt,mr,mg),opl(ml,mt,mr,mg)
  logical badnum,doprint
  character*16 chemfile
  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (ten = 1.0d+01)

  if(myrank.eq.0) then
     irec = 0
     open(unit=9,file='diskmodel',access='direct',recl=2*nt,err=98)
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           irec = irec+1
           read(unit=9,rec=irec,err=98) (dg(it,ir,ig),it=1,nt)
        enddo
     enddo
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           irec = irec+1
           read(unit=9,rec=irec,err=98) (tg(it,ir,ig),it=1,nt)
        enddo
     enddo
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           irec = irec+1
           read(unit=9,rec=irec,err=98) (td(it,ir,ig),it=1,nt)
        enddo
     enddo
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           irec = irec+1
           read(unit=9,rec=irec,err=98) (opl(ml,it,ir,ig),it=1,nt)
        enddo
     enddo
     close(unit=9)

     irec = 0
     open(unit=9,file='dustmodel',access='direct',recl=2*nu,err=99)
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              irec = irec+1
              read(unit=9,rec=irec,err=99) (opa(iu,it,ir,ig),iu=1,nu)
           enddo
        enddo
     enddo
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              irec = irec+1
              read(unit=9,rec=irec,err=99) (swd(iu,it,ir,ig),iu=1,nu)
           enddo
        enddo
     enddo
     close(unit=9)

     if((index(chemfile,' ').lt.2).or.(index(chemfile,'none').gt.0)) &
          goto 90
     open(unit=10,file=chemfile,err=90)
     read(10,'(1x)')
     read(10,*) chemtime
     read(10,*) ngrt
     igrt = 0
     rmsdg = zero
     rmstg = zero
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           r = dr*(ir-half)
           do it = 1,nt
              igrt = igrt+1
              z = r*dcosth*(nt-it+half)
              sumd = zero
              dgi = dg(it,ir,ig)
              tgi = tg(it,ir,ig)
              read(10,*) rch,zch,dgch,tgch,g0uv,xmol
              dl(8,it,ir,ig) = xmol
              rmsdg = rmsdg+(dgi-dgch)**2
              rmstg = rmstg+(tgi-tgch)**2
           enddo
        enddo
     enddo
     rmsdg = sqrt(rmsdg/ngrt)
     rmstg = sqrt(rmstg/ngrt)
     if(igrt.ne.ngrt) then
        print '(" Wrong chemfile length")'
        print '(6i8)', ng,nr,nt,nr9*nt+(ng+1)*(nr/2)*nt,ngrt,igrt
     endif
     if(rmstg.gt.ten) then
        print '(" Chemfile disagrees with diskmodel")'
        print '(1p,2e10.2)', rmsdg,rmstg
     endif
     goto 100
90   if(doprint) print '(" Using constant molecular abundance")'
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              !       enhance CO where carbon is burned
              if(tg(it,ir,ig).gt.tburn) then
                 dl(8,it,ir,ig) = xburn
              else
                 dl(8,it,ir,ig) = one
              endif
           enddo
        enddo
     enddo

100  do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           do it = 1,nt
              if(doprint.and.badnum(dg(it,ir,ig))) &
                   print '("dg(",3i4,") =",e10.2)', it,ir,ig,dg(it,ir,ig)
              if(doprint.and.badnum(tg(it,ir,ig))) &
                   print '("tg(",3i4,") =",e10.2)', it,ir,ig,tg(it,ir,ig)
              if(doprint.and.badnum(opl(ml,it,ir,ig))) print &
                   '("opl(",3i4,") =",e10.2)', it,ir,ig,opl(ml,it,ir,ig)
              do iu = 1,nu
                 if(doprint.and.badnum(opa(iu,it,ir,ig))) &
                      print '("opa(",4i4,") =",e10.2)', &
                      iu,it,ir,ig,opa(iu,it,ir,ig)
                 if(doprint.and.badnum(swd(iu,it,ir,ig))) &
                      print '("swd(",4i4,") =",e10.2)', &
                      iu,it,ir,ig,swd(iu,it,ir,ig)
              enddo
           enddo
        enddo
     enddo
  endif

  if(mysize.gt.0) then
     do igr = 0,ng
        call startgr(igr,ig,kr,lr,lt,dr,dcosth)
        do ir = kr,lr
           call mpi_bcast(dg(1,ir,ig),nt, &
                MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
           call mpi_bcast(tg(1,ir,ig),nt, &
                MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
           call mpi_bcast(td(1,ir,ig),nt, &
                MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
           do it = 1,nt
              call mpi_bcast(opl(ml,it,ir,ig),1, &
                   MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
              call mpi_bcast(opa(1,it,ir,ig),nu, &
                   MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
              call mpi_bcast(swd(1,it,ir,ig),nu, &
                   MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
              call mpi_bcast(dl(8,it,ir,ig),1, &
                   MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
           enddo
        enddo
     enddo
  endif

  call copyarr(dg)
  call copyarr(tg)
  call copyarr(td)
  call copyarrr(opl,ml,ml)
  call copyarrr(opa,mu,nu)
  call copyarrr(swd,mu,nu)
  call copyarrr(dl,ml,ml)

  return

98 print '(" Error reading diskmodel",5i8)', ir,ig,irec,8*nt
  stop

99 print '(" Error reading dustmodel",5i8)', it,ir,ig,irec,8*nu
  stop

end subroutine readmodel



subroutine readparms
  !	read pisco.par file

  implicit real*8 (a-h,o-z)
  parameter (mc = 256)

  common /mpis/ mysize,myrank
  common /nn/ nx,ny,nz,ng,nw,nr,nt,na,nu,nl,nrot,lw,ll,nit
  common /nines/ nx9,nz9,nr9,ng9,nn9,mm9,dx9,dz9,dr9
  common /consts/ we,be,ae,hc,sv,wec,acoeff,gnucl,popiso,moltype
  common /parms/ dx0,dz0,dr0,dv,dvturb0,dvturb1,vterm,rstar,tstar
  common /heat/ gmmdot,acom,pxr,axr,bxr,epspe,agas,sigma, &
       colin,colup,xco,xwat
  common /angls/ dcost,dcos9,rot,irot
  common /parmz/ rgrid1,r0,r1,sigma0,sigma1,ocol,pcol,qcol, &
       avisc,xmstar,xlstar,tuv,xuv,tsubl,gsubl,tburn,xburn, &
       coswind,xc,xsi,ac,asi,xmdot,wmdot,vwind, &
       xco0,xwat0,tfrco,tfrwat,xmol,tfrmol,tdiss,coldiss, &
       kit,lit,mit,nnt,lx,lrot,reuse
  common /cube/ cube(mc,mc,mc),ngc
  logical doprint,reuse
  character*80 line,parn,parv

  parameter (zero = 0.0d+00)
  parameter (one = 1.0d+00)
  parameter (two = 2.0d+00)
  parameter (half = 0.5d+00)
  parameter (quart = 0.25d+00)
  parameter (pi = 3.14159265d+00)
  parameter (au = 1.496d+13)
  parameter (rsun = 6.96d+10)
  parameter (xlsun = 3.90d+33)
  parameter (xmsun = 1.99d+33)
  !	mass / gas particle
  parameter (xmg = 4.0d-24)
  parameter (vkms = 1.0d+05)

  doprint = (myrank.eq.0)
  open(unit=17,file='pisco.par')

100 read(unit=17,fmt='(a72)',err=90,end=90) line
  if(index(line,'c').eq.1) then
     continue
  elseif(index(line,'=').gt.0) then
     if(doprint) print '(a72)', line(1:72)
     npar = index(line,'=')-1
     parn = line(1:npar)
     npar = npar+2
     parv = line(npar:72)
     if(index(parn,'reuse').gt.1) then
        reuse = (index(parv,'t').gt.1)
     elseif(index(parn,'rgrid1').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) rgrid1
        rgrid1 = rgrid1*au
     elseif(index(parn,'r0 ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) r0
        r0 = r0*au
     elseif(index(parn,'r1 ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) r1
        r1 = r1*au
     elseif(index(parn,'sigma0').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) sigma0
     elseif(index(parn,'sigma1').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) sigma1
     elseif(index(parn,'pcol').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) pcol
     elseif(index(parn,'qcol').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) qcol
     elseif(index(parn,'ocol').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) ocol
     elseif(index(parn,'avisc').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) avisc
     elseif(index(parn,'rstar').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) rstar
        rstar = rstar*rsun
     elseif(index(parn,'mstar').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xmstar
     elseif(index(parn,'lstar').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xlstar
     elseif(index(parn,'tstar').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tstar
     elseif(index(parn,'tuv ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tuv
     elseif(index(parn,'xuv ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xuv
     elseif(index(parn,'tsubl').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tsubl
     elseif(index(parn,'gsubl').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) gsubl
     elseif(index(parn,'tburn').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tburn
     elseif(index(parn,'xburn').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xburn
     elseif(index(parn,'wmdot').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) wmdot
     elseif(index(parn,'mdot').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xmdot
     elseif(index(parn,'acom').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) acom
     elseif(index(parn,'pxr ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) pxr
     elseif(index(parn,'axr ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) axr
     elseif(index(parn,'bxr ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) bxr
     elseif(index(parn,'epspe').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) epspe
     elseif(index(parn,'xco').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xco0
     elseif(index(parn,'xwat').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xwat0
     elseif(index(parn,'tfrco').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tfrco
     elseif(index(parn,'tfrwat').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tfrwat
     elseif(index(parn,'coswind').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) coswind
     elseif(index(parn,'vwind').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) vwind
     elseif(index(parn,'dvturb0').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) dvturb0
        dvturb0 = dvturb0*vkms
     elseif(index(parn,'dvturb1').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) dvturb1
        dvturb1 = dvturb1*vkms
     elseif(index(parn,'dv ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) dv
        dv = dv*vkms
     elseif(index(parn,'xmol').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xmol
     elseif(index(parn,'coldiss').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) coldiss
     elseif(index(parn,'tdiss').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tdiss
     elseif(index(parn,'tice').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tfrmol
     elseif(index(parn,'tfrmol').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) tfrmol
     elseif(index(parn,'xc ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xc
     elseif(index(parn,'xsi ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) xsi
     elseif(index(parn,'ac ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) ac
     elseif(index(parn,'asi ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) asi
     elseif(index(parn,'kit ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) kit
     elseif(index(parn,'lit ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) lit
     elseif(index(parn,'mit ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) mit
     elseif(index(parn,'ng ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) ng
        ngc = ng/2
     elseif(index(parn,'nn9 ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nn9
     elseif(index(parn,'nr ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nr
     elseif(index(parn,'nnt ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nnt
     elseif(index(parn,'nt ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nt
     elseif(index(parn,'nrot').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nrot
     elseif(index(parn,'lrot').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) lrot
     elseif(index(parn,'npl ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) npl
     elseif(index(parn,'nx ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) nx
     elseif(index(parn,'lx ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) lx
     elseif(index(parn,'ngc ').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) ngc
     elseif(index(parn,'moltype').gt.1) then
        read(unit=parv,fmt=*,err=90,end=90) moltype
     else
        if(doprint) print '("I don''t understand",a60)', line(1:60)
     endif
  endif
  goto 100

90 close(unit=17)
  return
end subroutine readparms




function badnum(val)
  !	test val for NaN or Inf

  implicit real*8 (a-h,o-z)
  logical badnum

  if(val.eq.(0.0d+00)) then
     badnum = .false.
  else
     test = val/val
     badnum = (test.ne.test)
  endif

  return
end function badnum
